Copy data from 1 workbook to a template workbook rearranging data

[Abraxus]

I have an input file that needs some of its data copied to a template file for another process.

I know how to open each file, but I'm not sure how to go row by row through the import file and put that data into the template file in the proper columns.

For example, for every row in the input file:

• Data in Column A goes into the template file Column D
• Data in Column F goes into the template file Column B
• And so on...

It has to be done row by row because I have to build some numbering logic in, too. I hope this makes sense.

Here's my code so far:

Code: Select all

Sub CreateTheFile()
    
    Dim strCurrentDirectory As String
    strCurrentDirectory = CurDir
    Dim strTemplateFilePath As String
    strTemplateFilePath = strCurrentDirectory & "\Template\Template.xlsx"
    Dim strInputPath As String
    strInputPath = strCurrentDirectory & "\Input\"
    Dim strOutputPath As String
    strOutputPath = strCurrentDirectory & "\Output\"
    
    Debug.Print strCurrentDirectory
    Debug.Print strTemplateFilePath
    Debug.Print strInputPath
    Debug.Print strOutputPath
    
    'Open the input file
    Dim strFile As String
    strFile = Dir(strInputPath & "*.xls*")
    Set wbinput = Workbooks.Open(strInputPath & strFile)
  
    'Sort it
    wbinput.Worksheets(1).Sort.SortFields.Clear
    wbinput.Worksheets(1).Sort.SortFields.Add2 Key:=Range("I2:I10000" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    wbinput.Worksheets(1).Sort.SortFields.Add2 Key:=Range("A2:A10000" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wbinput.Worksheets(1).Sort
        .SetRange Range("A1:X10000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    
    'Open the template file
    Set wbTemplate = Workbooks.Open(strTemplateFilePath)
    
    'Write the output data
    'HERE'S WHERE I"M STUMPED
    
    'Save the template file to output
    
    'Close imput file
    Workbooks(strFile).Close savechanges:=False
    'Move imput file
    FileCopy strInputPath & strFile, strInputPath & "Done\" & Format(Now, "YYYYMMDDHHMM") & "-" & strFile
    Kill strInputPath & strFile
    'All Done!
    MsgBox "Done!"
    
End Sub

Any pointers are appreciated!

[HansV]

Does this help?

Code: Select all

Sub CreateTheFile()
    
    Dim strCurrentDirectory As String
    strCurrentDirectory = CurDir
    Dim strTemplateFilePath As String
    strTemplateFilePath = strCurrentDirectory & "\Template\Template.xlsx"
    Dim strInputPath As String
    strInputPath = strCurrentDirectory & "\Input\"
    Dim strOutputPath As String
    strOutputPath = strCurrentDirectory & "\Output\"
    
    Debug.Print strCurrentDirectory
    Debug.Print strTemplateFilePath
    Debug.Print strInputPath
    Debug.Print strOutputPath
    
    'Open the input file
    Dim strFile As String
    strFile = Dir(strInputPath & "*.xls*")
    Dim wbInput As Workbook
    Set wbInput = Workbooks.Open(strInputPath & strFile)
  
    Dim wsInput As Worksheet
    Set wsInput = wbInput.Worksheets(1)
    'Sort it
    With wsInput.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("I2:I10000"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add2 Key:=Range("A2:A10000"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:X10000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Open the template file
    Dim wbTemplate As Workbook
    Set wbTemplate = Workbooks.Open(strTemplateFilePath)
    Dim wsOutput As Worksheet
    Set wsOutput = wbTemplate.Worksheets(1)
    
    'Write the output data
    ' Get the last used row
    Dim lastRow As Long
    lastRow = wsInput.Range("A:X").Find(What:="*", SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    ' Loop through the rows
    Dim r As Long
    For r = 2 To lastRow
        ' Transfer some values
        wsOutput.Range("D" & r).Value = wsInput.Range("A" & r).Value
        wsOutput.Range("B" & r).Value = wsInput.Range("F" & r).Value
        ' etc.
    Next r
    
    'Save the template file to output
    
    'Close input file
    wbInput.Close SaveChanges:=False
    'Move input file
    FileCopy strInputPath & strFile, strInputPath & "Done\" & Format(Now, "YYYYMMDDHHMM") & "-" & strFile
    Kill strInputPath & strFile
    'All Done!
    MsgBox "Done!"
    
End Sub

[Abraxus]

Thank you so much! Great starting point and I was able to do what I needed!