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

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

Answer 1

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.

Answer 2

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

Answer 3

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

Answer 4

'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