Excel VBA how to create repetition

[Kabeka]

Hi All,

I have a short macro which opens 2 files, copies data from one to the other and saves it by a certain name (save as).
So far it works,it takes the first line of my data table and updates the other document correctly.
However, I need to create several new files with the data of each row in the original file.

Can I get excel to identify the column headers by name and take the data from the cells underneath row by row?

For example, this is the table in the first document:

ID	Supplyer	Case owner	month of purchase	Cost
IT2	Kia	Joe	2018-01	10
FM4	Daewoo	Mike	2018-02	20
MK1	Hyundai	Judy	2018-03	30

<tbody>
</tbody><colgroup><col span="2"><col><col><col></colgroup>

Then I need new document 1 containing:
IT2, Kia, Joe, 2018-01, 10 - in certain cells

Next, I need another document containing:
FM4, Daewoo, Mike, 2018-02, 20 - in the same cells

The code I have now is unfortunately very simple:

Sub TransferData()
'transfer stuff from Saving tracker to Business case template
Dim strPath1 As String
Dim strPath2 As String
Dim wbkWorkbook1 As Workbook
Dim wbkWorkbook2 As Workbook
'define paths and filenames
strPath1 = "C:\Business cases\Savings Tracker.xlsx"
strPath2 = "C:\Business cases\Business case template.xlsx"
'open files
Set wbkWorkbook1 = Workbooks.Open(strPath1)
Set wbkWorkbook2 = Workbooks.Open(strPath2)
'copy the values across
'saving number
wbkWorkbook2.Worksheets("Supplier").Range("E7").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("B7").Value
wbkWorkbook2.Worksheets("Supplier").Range("E6").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("G7").Value
wbkWorkbook2.Worksheets("Supplier").Range("E9").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("W7").Value
wbkWorkbook2.Worksheets("Supplier").Range("E10").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("V7").Value
wbkWorkbook2.Worksheets("Supplier").Range("E11").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("AD7").Value
wbkWorkbook2.Worksheets("Supplier").Range("E12").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("X7").Value
wbkWorkbook2.Worksheets("Supplier").Range("E13").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("I7").Value
wbkWorkbook2.Worksheets("Supplier").Range("J12").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("E7").Value
wbkWorkbook2.Worksheets("Supplier").Range("J13").Value = _
wbkWorkbook1.Worksheets("Saving tracker").Range("F7").Value


'define new filename and save
FNAME = wbkWorkbook2.Name
FNAME = Left(FNAME, Len(FNAME) - 4)
currDate = Format(Now(), "yyyy-mm-dd")
wbkWorkbook2.SaveAs Filename:="C:\Business cases" & FNAME & wbkWorkbook2.Worksheets("Supplier").Range("E7").Value & " " & currDate & ".xlsx", _
FileFormat:=51, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

'close the two workbooks
wbkWorkbook1.Close (False)
wbkWorkbook2.Close (True)
End Sub

I would appreciate your help on this

 

[AlphaFrog]

Try this (not tested)...

[color=darkblue]Sub[/color] TransferData()
[color=green]'transfer stuff from Saving tracker to Business case template[/color]
    
    [color=darkblue]Dim[/color] strPath1  [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] strPath2  [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wb1       [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] wb2       [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] FNAME     [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] currDate  [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] ws1       [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] ws2       [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] cell      [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] counter   [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=green]'define paths and filenames[/color]
    strPath1 = "C:\Business cases\Savings Tracker.xlsx"
    strPath2 = "C:\Business cases\Business case template.xlsx"
    
    [color=green]'open files[/color]
    [color=darkblue]Set[/color] wb1 = Workbooks.Open(strPath1)
    [color=darkblue]Set[/color] wb2 = Workbooks.Open(strPath2)
    
    [color=green]'define new base filename[/color]
    FNAME = Left(wb2.Name, Len(wb2.Name) - 4)
    currDate = Format(Now, "yyyy-mm-dd")
    
    [color=green]'Define sheets[/color]
    [color=darkblue]Set[/color] ws1 = wb1.Worksheets("Saving tracker")
    [color=darkblue]Set[/color] ws2 = wb2.Worksheets("Supplier")
    
    [color=green]'copy the values across[/color]
    [color=green]'saving number[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] ws1.Range("B7", ws1.Range("B" & Rows.Count).End(xlUp))
        
        ws2.Range("E7").Value = cell.Value
        ws2.Range("E6").Value = ws1.Range("G" & cell.Row).Value
        ws2.Range("E9").Value = ws1.Range("W" & cell.Row).Value
        ws2.Range("E10").Value = ws1.Range("V" & cell.Row).Value
        ws2.Range("E11").Value = ws1.Range("AD" & cell.Row).Value
        ws2.Range("E12").Value = ws1.Range("X" & cell.Row).Value
        ws2.Range("E13").Value = ws1.Range("I" & cell.Row).Value
        ws2.Range("J12").Value = ws1.Range("E" & cell.Row).Value
        ws2.Range("J13").Value = ws1.Range("F" & cell.Row).Value
        
        [color=green]'Save[/color]
        wb2.SaveAs Filename:="C:\Business cases\" & FNAME & ws2.Range("E7").Value & " " & currDate & ".xlsx", _
                   FileFormat:=51, Password:="", WriteResPassword:="", _
                   ReadOnlyRecommended:=False, CreateBackup:=[color=darkblue]False[/color]
        
        counter = counter + 1
    
    [color=darkblue]Next[/color] cell
    
    [color=green]'close the two workbooks[/color]
    wb1.Close [color=darkblue]False[/color]
    wb2.Close False
    
    MsgBox counter & " files saved.", vbInformation, "Transfer Data Complete"
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[Kabeka]

Great help, works like a charm. I really appreciate it.