none
VBA code to create 3 workbooks and same variables RRS feed

  • Question

  • Hello Developers! 

    I would like to seek your help in this macro. Basically, I have a raw data where I run a macro to spit out 2 workbooks and will use the same variables. After creating the first workbook, saves to new filename then close workbook. Adds 2nd workbook, use same variables, saves new filename then closes workbook. I am able to create the first workbook successfully that I want in the first output but the 2nd workbook does not seem to copy the same arrays. 

    Thank you in advance for your recommendations!

    Dim HBL(1 To 1000), QTY(1 To 1000), CLIENT(1 To 1000), WEIGHT(1 To 1000) As String
    Dim MI(1 To 1000), VOL(1 To 1000) As String
    Dim irow, arraynumber, arraynumberEnd As Double
    
    
    
    endOfSheet = ActiveSheet.UsedRange.Rows.Count
    
    With ActiveSheet
    arraynumber = 1
    
    For irow = 2 To endOfSheet
            
      
            HBL(arraynumber) = Trim(Range("D" & irow))
            CLIENT(arraynumber) = Trim(Range("B" & irow))
            WEIGHT(arraynumber) = Trim(Range("C" & irow))
            QTY(arraynumber) = Trim(Range("G" & irow))
            VOL(arraynumber) = Trim(Range("F" & irow))
            arraynumber = arraynumber + 1
       
            
    Next irow
    
    Sub gogo()
    
    
    Dim HBL(1 To 1000), QTY(1 To 1000), CLIENT(1 To 1000), WEIGHT(1 To 1000) As String
    Dim MI(1 To 1000), VOL(1 To 1000) As String
    Dim irow, arraynumber, arraynumberEnd As Double
    
    
    
    
    'MAIN CODE BLOCK - START OF CODE
    
    Application.ScreenUpdating = False ' turns screen updating off - won't show flashing screens
    Application.DisplayAlerts = False
    relativePath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        
    'endOfSheet = ActiveSheet.UsedRange.Rows.Count
    
    
    
    FileString = "C:\Users\LRG\Desktop\gogo" & ".csv"
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
           FileString, FileFormat _
          :=xlCSV, CreateBackup:=False
    
    
    'Insert row after D
    Columns("E:E").Insert Shift:=xlToLeft, _
          CopyOrigin:=xlFormatFromRightOrAbove 'or xlFormatFromLeftOrBelow
    
    Range("E1") = "HBL"
    
    'Trim HBL
    Range("E2:E" & Range("A" & Rows.Count).End(xlUp).row).Formula = "=LEFT(D2,10)"
    
     'Paste as value Col E
        Columns(5).Copy
        Columns(5).PasteSpecial xlPasteValues
        
    'Delete Col D
    Worksheets("gogo").Columns("D:D").EntireColumn.Delete
    
    
    'Convert to number
    Range("D:D").Select
    With Selection
    Selection.NumberFormat = "General"
    .Value = .Value
    End With
    
    
    'Autofitting Cells
    Columns("A:G").AutoFit
    
    
    endOfSheet = ActiveSheet.UsedRange.Rows.Count
    
    With ActiveSheet
    arraynumber = 1
    
    For irow = 2 To endOfSheet
            
      
            HBL(arraynumber) = Trim(Range("D" & irow))
            CLIENT(arraynumber) = Trim(Range("B" & irow))
            WEIGHT(arraynumber) = Trim(Range("C" & irow))
            QTY(arraynumber) = Trim(Range("G" & irow))
            VOL(arraynumber) = Trim(Range("F" & irow))
            arraynumber = arraynumber + 1
       
            
    Next irow
    
    LastArray = arraynumber - 1
    
    '******************************
    'CREATE SKI SPREADSHEET
    '******************************
    
    
    Workbooks.Add
    
    
    
    'Adds headers to new sheet
    Range("A1") = "SKI"
    Range("B1") = "GXXXXX"
    Range("C1") = ""
    Range("D1") = ""
    Range("E1") = ""
    Range("F1") = ""
    Range("G1") = ""
    Range("H1") = ""
    Range("I1") = ""
    Range("M1") = ""
    Range("N1") = ""
    
    
    
    trow = 2
    For arraynumber = 1 To LastArray
        Range("A" & trow) = "DET"
        Range("B" & trow) = HBL(arraynumber)
        Range("C" & trow) = CLIENT(arraynumber)
        Range("D" & trow) = VOL(arraynumber)
        Range("E" & trow) = "CBM"
        Range("F" & trow) = "P"
        Range("G" & trow) = WEIGHT(arraynumber)
        Range("H" & trow) = "KG"
        Range("I" & trow) = "P"
        Range("M" & trow) = "1"
        Range("N" & trow) = QTY(arraynumber)
        
         
            
        
    trow = trow + 1
    
    Next
    
    
    
    
    'Freeze top row
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    
    
    'If col D is "0" change it to 25
    
    With ActiveSheet
             
             'Assuming data start in A1, store in array
            ar = .Cells(1).CurrentRegion.Value
             
             
            For I = 1 To UBound(ar, 1)
                If ar(I, 4) = "0" Then
                    ar(I, 4) = "25" 'D
                               
                    End If
            Next I
             
             'Paste back values
            .Cells(1).Resize(UBound(ar, 1), UBound(ar, 2)).Value = ar
             
        End With
    
    'Autofitting Cells to make it appear cleaner
    Columns("A:N").AutoFit
    
    
    
    FileString = "C:\Users\LRG\Desktop\SKI" & Format(Date, "mm-dd-yy") & ".csv"
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
           FileString, FileFormat _
          :=xlCSV, CreateBackup:=False
    
    
    
    
           'ActiveWorkbook.Close SaveChanges:=True
           'ActiveWorkbook.Close SaveChanges:=True
    
    Workbooks.Open Filename:= _
            "\\C:\Users\LRG\Desktop\gogo.csv"
     
    
    
     
     '******************************
     'CREATE AXE SPREADSHEET
     '******************************
     
    
    Workbooks.Add
    
    
    
    'Application.ScreenUpdating = False ' turns screen updating off - won't show flashing screens
    'Application.DisplayAlerts = False
    'relativePath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        
        
       
        
    endOfSheet = ActiveSheet.UsedRange.Rows.Count
    
    With ActiveSheet
    arraynumber = 1
    
    For irow = 2 To endOfSheet
            
            qty(arraynumber) = Trim(Range("G" & irow))
            HBl(arraynumber) = Trim(Range("D" & irow))
          
           
            arraynumber = arraynumber + 1
       
            
    Next irow
    
    LastArray = arraynumber - 1
    
    
    
    
    trow = 3
    For arraynumber = 1 To LastArray
        Range("A" & trow) = "DET"
        Range("C" & trow) = HBL(arraynumber)
        Range("D" & trow) = qty(arraynumber)
       
       
        
    trow = trow + 1
    
    Next
    
    
    
    'Adds headers to new workbook
    Range("A1") = "AXE"
    Range("A2") = "SHP"
    Range("B1") = "GXXXXX"
    Range("C1") = "P"
    Range("H2") = "OTHR"
    Range("I2") = "NA"
    Range("M2") = "OT"
    
    
    
    
    With Range("D1")
    .Value = Now()
    .NumberFormat = "DDMMMYYYYhhmm"
    End With
    
    
    With Range("E1")
    .Value = Now()
    .NumberFormat = "DDMMMYYYY"
    End With
    
    
    With Range("G2")
    .Value = Now()
    .NumberFormat = "DDMMMYYYY"
    End With
    
    
    With Range("J2")
    .Value = Now()
    .NumberFormat = "DDMMMYYYY"
    End With
    
    
    With Range("K2")
    .Value = Now()
    .NumberFormat = "DDMMMYYYYhhmm"
    End With
    
    
    With Range("L2")
    .Value = Now()
    .NumberFormat = "DDMMMYYYY"
    End With
    
    Range("A1").Interior.ColorIndex = 48
    Range("A2").Interior.ColorIndex = 48
    Range("B1").Interior.ColorIndex = 48
    Range("C1").Interior.ColorIndex = 48
    Range("H2").Interior.ColorIndex = 48
    Range("I2").Interior.ColorIndex = 48
    Range("M2").Interior.ColorIndex = 48
    
    
    For Each cell In Range("A:A")
        If cell.Value = "DET" Then
            cell.Interior.ColorIndex = 48
        End If
    Next cell
    
    
    
    End With
    
    
    
    'Autofitting Cells to make it appear cleaner
    Columns("A:L").AutoFit
    
    
    'Save the file- TEST LOCATION
    FileString = "C:\Users\LRG\Desktop\GXXXXX AXE" & Format(Date, "mm-dd-yy") & ".csv"
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
          FileString, FileFormat _
          :=xlCSV, CreateBackup:=False
    
    
    
    
    
    'Closes the workbook
      'Range("A1").Select
       ' ActiveWorkbook.Close SaveChanges:=True
    
    
    End With
    
    
    
    MsgBox ("DONE")
    
    
    
    End Sub
    

    LastArray = arraynumber - 1
    
    
    


    Monday, April 16, 2018 11:56 PM

Answers

  • Thanks James for checking. I actually was able to resolve my problem. The command to add a workbook was not in the right place. I had to move the "Workbooks.add" code AFTER declaring my arrays. It added the second workbook and the arrays were in the right columns which i needed. 
    endOfSheet = ActiveSheet.UsedRange.Rows.Count
    
    With ActiveSheet
    arraynumber = 1
    
    For irow = 2 To endOfSheet
            
            QTY(arraynumber) = Trim(Range("G" & irow))
            HBL(arraynumber) = Trim(Range("D" & irow))
          
           
            arraynumber = arraynumber + 1
       
            
    Next irow
    
    LastArray = arraynumber - 1
    
    
    
    Workbooks.Add
    
    trow = 3
    For arraynumber = 1 To LastArray
        Range("A" & trow) = "DET"
        Range("C" & trow) = HBL(arraynumber)
        Range("D" & trow) = QTY(arraynumber)
       
       
        
    trow = trow + 1
    
    Next
    
    

    • Proposed as answer by Terry Xu - MSFT Wednesday, April 18, 2018 2:12 AM
    • Marked as answer by IamJackie Wednesday, April 18, 2018 3:22 PM
    Tuesday, April 17, 2018 11:29 PM

All replies

  • IamJackie,
    re:  problem code recommendation

    That is a very large code set to ask someone to go thru.
    You don't explain what the block of code above the sub is.
    You don't explain what the line of code below the sub is.

    Add "Option Explicit" as the first line in the module - no quote marks
    That will force you to declare all variables - there are a bunch.

    When declaring variables, you must explicitly declare the data type for each variable.
    If you don't as in:  "Dim irow, arraynumber, arraynumberEnd As Double" then
      irow and arraynumber are Variants.
    The declaration line should read..."Dim irow as Double, arraynumber asDouble, arraynumberEnd As Double"
    (each probably should be a Long)

    If you are using "On Error Resume Next", but haven't shown it, then comment it out.
    When developing, its use hides errors that should be corrected.
    Such as the following which errors on my xl2010 version...
    '---
    'Insert row after D  '<<< actually a column
    Columns("E:E").Insert Shift:=xlToLeft, _
          CopyOrigin:=xlFormatFromRightOrAbove 'or xlFormatFromLeftOrBelow
    '---

    Remove all of the blank rows - except single rows to separate code sections.
    Then edit your original post by replacing the posted code with the improved? version.
    Post a "response" outlining your changes and maybe someone will bite.

    Note:  VBA includes a "FileCopy" statement that can copy a file and place the copy in any folder.
    Syntax:
    FileCopy source, destination

    '---
    Jim Cone
    (it gets easier)

    Tuesday, April 17, 2018 3:09 PM
  • Thanks James for checking. I actually was able to resolve my problem. The command to add a workbook was not in the right place. I had to move the "Workbooks.add" code AFTER declaring my arrays. It added the second workbook and the arrays were in the right columns which i needed. 
    endOfSheet = ActiveSheet.UsedRange.Rows.Count
    
    With ActiveSheet
    arraynumber = 1
    
    For irow = 2 To endOfSheet
            
            QTY(arraynumber) = Trim(Range("G" & irow))
            HBL(arraynumber) = Trim(Range("D" & irow))
          
           
            arraynumber = arraynumber + 1
       
            
    Next irow
    
    LastArray = arraynumber - 1
    
    
    
    Workbooks.Add
    
    trow = 3
    For arraynumber = 1 To LastArray
        Range("A" & trow) = "DET"
        Range("C" & trow) = HBL(arraynumber)
        Range("D" & trow) = QTY(arraynumber)
       
       
        
    trow = trow + 1
    
    Next
    
    

    • Proposed as answer by Terry Xu - MSFT Wednesday, April 18, 2018 2:12 AM
    • Marked as answer by IamJackie Wednesday, April 18, 2018 3:22 PM
    Tuesday, April 17, 2018 11:29 PM
  • Hello lamJackie,

    I'm glad to hear that you have solved the issue. I would suggest you mark your solution as answer to close this thread.

    If you have other issue, please feel free to post threads to let us know.

    Thanks for understanding.

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, April 18, 2018 2:12 AM