Copy data from multiple files into one sheet with incremental rows.

Question

I'm using the following code to open one of multiple files, copy a line from a worksheet, and then paste it back into the first worksheet, then close the opened file.

My problem is I can't get past the function to move down the rows each time it pastes. I want it to incrementally paste the values on the new row, ie. B3, then B4, then B5, etc.

Sub Auto_open_change()
    Dim WrkBook As Workbook
    Dim StrFileName As String
    Dim FileLocnStr As String
    Dim LAARNmeWrkbk As String

    PERNmeWrkbk = ThisWorkbook.Name

    FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path

    Dim StrFile As String
    StrFile = Dir(FileLocnStr & "\*.xls")
    Do While Len(StrFile) > 0
        DoStuff (FileLocnStr & "\" & StrFile)
        StrFile = Dir
    Loop
End Sub

Private Sub DoStuff(StrFileName)
    Workbooks.Open (StrFileName)
    Call Edit
    Workbooks.Open (StrFileName)
    ActiveWorkbook.Close
End Sub

Sub Edit()
    Dim Wb1 As Workbook
    Dim ws1 As Worksheet
    Dim loopcal As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
    End With

    Set Wb1 = ActiveWorkbook
    Sheets("1_3 Octave1 CH1").Select
    Range("A3:AH3").Select
    Selection.Copy

    Windows("template.xlsm").Activate
    Sheets("Data Extract").Select
    Range("B3").Select

    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

did you try putting or calling your macro within a loop and stepping through the cells? — Sammy, Dec 24 '13 at 01:52
I havn't tried that, and im unsure whats the best way as the rows are undefined and change in frequency each time the marco is run. Im also unsure where to define the loop. Iv hacked the current macro together and just managed to make it work. any help would be appreciated. — Adrian Gornall, Dec 24 '13 at 02:21

score 2 · Accepted Answer · answered Dec 24 '13 at 08:32

You can try this:

Sub GetData(Fname as String)

Dim wb1, wb2 as Workbook
Dim ws1, ws2 as Worksheet
Dim lrow as Long

Set wb1 = Thisworkbook
Set ws1 = wb1.Sheets("DataExtract")
Set wb2  = Worbooks.Open(Fname)
Set ws2 = wb2.Sheets("1_3 Octave1 CH1")

With ws1
    lrow = .Range("B" & Rows.Count).End(xlUp).Row
    ws2.Range("A3:AH3").Copy
    .Range("B" & lrow).Offset(1,0).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End With

wb2.Close False

End Sub

Just replace DoStuff and Edit subs.
hope this helps.

score 1 · Answer 2 · answered Dec 24 '13 at 04:04

Untested:

Sub Auto_open_change()

    Dim StrFileName As String
    Dim FileLocnStr As String
    Dim fNum As Long
    Dim StrFile As String

    FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    fNum = 1
    StrFile = Dir(FileLocnStr & "\*.xls")

    Do While Len(StrFile) > 0
        CopyData FileLocnStr & "\" & StrFile, fNum
        StrFile = Dir
        fNum = fNum + 1
    Loop

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With


End Sub


Sub CopyData(StrFileName As String, fNum As Long)
    Dim Wb1 As Workbook, rngCopy As Range
    Dim rngDest As Range

    Set Wb1 = Workbooks.Open(StrFileName)
    Set rngCopy = Wb1.Sheets("1_3 Octave1 CH1").Range("A3:AH3")
    Set rngDest = ThisWorkbook.Sheets("Data Extract") _
                        .Range("B2").Offset(fNum, 0)

    rngCopy.Copy rngDest
    With rngDest.Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
        .Value = .Value
    End With

    Wb1.Close False

End Sub

Lance Roberts · Answer 3 · 2014-01-01T23:25:13.423

1

Well, with the code you're using, you could just create a variable in the Do While Loop that calls DoStuff and pass it through to the Edit sub, then construct the range from that.

So in the Do While Loop

rowcounter = 3
Do While Len(StrFile) > 0
    DoStuff (FileLocnStr & "\" & StrFile, rowcounter)
    StrFile = Dir
    rowcounter = rowcounter + 1
Loop

Then modify DoStuff

Private Sub DoStuff(StrFileName As String, rowcounter As Integer)
    Workbooks.Open (StrFileName)
    Call Edit(rowcounter)
    Workbooks.Open (StrFileName)
    ActiveWorkbook.Close
End Sub

Then modify Edit

Sub Edit(rowcounter As Integer)
    .
    .

    .
    .

    Windows("template.xlsm").Activate
    Sheets("Data Extract").Select
    Range("B" & rowcounter).Select
    .
    .
End Sub

edited Jan 01 '14 at 23:25

answered Dec 24 '13 at 05:37

Lance Roberts

22,383
32
112
130

I have made the changes as suggested, however im getting an error: complie error: By Ref argument Type mismatch. in the Private Sub DoStuff(StrFileName, rowcounter) section and its highlighting Call Edit (rowcounter) any clues? – Adrian Gornall Jan 01 '14 at 22:28
Just had to call the (rowcounter as integer) in the Edit sub. thanks – Adrian Gornall Jan 01 '14 at 22:50
@AdrianGornall, Thanks, I had missed that, edited in. – Lance Roberts Jan 01 '14 at 23:25

score 0 · Answer 4 · edited Jan 01 '14 at 22:52

'Guys, here is the final edit. works perfectly, Thanks for the help and support guys.

Option Explicit

Sub Auto_open_change()

    Dim WrkBook As Workbook
    Dim StrFileName As String
    Dim FileLocnStr As String
    Dim LAARNmeWrkbk As String
    Dim rowcounter As Integer

    FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path

    Dim StrFile As String
    StrFile = Dir(FileLocnStr & "\*.xls")

    rowcounter = 3
    Do While Len(StrFile) > 0
    Call DoStuff(FileLocnStr & "\" & StrFile, rowcounter)
    StrFile = Dir
    rowcounter = rowcounter + 1
Loop

End Sub
Private Sub DoStuff(StrFileName As String, rowcounter As Integer)

    Workbooks.Open (StrFileName)

    Call Edit(rowcounter)

    Workbooks.Open (StrFileName)

    ActiveWorkbook.Close

End Sub

Sub Edit(rowcounter As Integer)
Dim Wb1 As Workbook
Dim ws1 As Worksheet
Dim loopcal As Long
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    lngCalc = .Calculation
 End With

     Set Wb1 = ActiveWorkbook
    Sheets("1_3 Octave1 CH1").Select
    Range("A3:AH3").Select
    Selection.Copy

    Windows("template.xlsm").Activate
    Sheets("Data Extract").Select
    Range("B" & rowcounter).Select

'index the variable to ensure the cell reference changes each time.
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End Sub

Please pay more attension to formatting your code. Also, use of `Select` is bad code. See [this](http://stackoverflow.com/a/10717999/445425) for some hint on how to avoid it. — chris neilsen, Jan 01 '14 at 22:53

Copy data from multiple files into one sheet with incremental rows.

4 Answers4