Excel VBA how to create repetition

Kabeka

New Member
Joined
Feb 8, 2018
Messages
2
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:
IDSupplyerCase ownermonth of purchaseCost
IT2KiaJoe2018-0110
FM4DaewooMike2018-0220
MK1HyundaiJudy2018-0330

<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
 

Some videos you may like

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,377
Try this (not tested)...

Code:
[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]
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,122,364
Messages
5,595,722
Members
414,013
Latest member
tnobbs

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top