I'm trying to paste the rows 8-18 on sheet2 and have this looping for multiple workbooks and I want the next selection to paste on the last row. For example if the lastrow is 2 to start, it should paste between 2-12 and the following workbook should paste on 13-23 and so on. The last line that refers to ("B4") I need this to on all ten lines repeating. My code doesn't seem to be working.
Sub PullAP()
Dim Source As Workbook
Dim MyDate, MyMonth
MyDate = Date
MyMonth = Month(MyDate) + 1
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lastRow As Long
'Speed up macro
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension
myExtension = "*.xls*"
'Target Path with Ending Extension
myFile = Dir(myPath & myExtension)
'Loop through each excel file in folder
Do While myFile <> ""
'Set varibale equal to open workbook
Set Source = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to the next line of code
DoEvents
'Code
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row + 1
ThisWorkbook.Worksheets("Sheet2").Range("A" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("A8:A18").Value
ThisWorkbook.Worksheets("Sheet2").Range("D" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("D8:D18").Value
ThisWorkbook.Worksheets("Sheet2").Range("E" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("E8:E18").Value
ThisWorkbook.Worksheets("Sheet2").Range("F" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("F8:F18").Value
ThisWorkbook.Worksheets("Sheet2").Range("B" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("B4").Value
'Close without saving
Source.Close SaveChanges:=False
'Ensure Workbook has closed before next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
MsgBox "Task Complete!"
ResetSettings:
'Resets optimization settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I believe you are trying to do this:
dim lrs as long, lrd as long, i as long
for i = 1 to workbooks(1).sheets.count
with workbooks(1).sheets(i)
lrs = .cells(.rows.count,1).end(xlup).row
.range(.cells(1,1),.cells(lrs,1)).Copy
end with
with workbooks("dest").sheets("name")
lrd = .cells(.rows.count,1).end(xlup).row
.range(.cells(lrd+1,1),.cells(lrd+1+lrs,1)).PasteSpecial xlValues
end with
next i
Untested, but should give the right idea. You will need to find and provide an entire range to paste into (last row destination + last row source + 1).
You could also value = value, like you have, but in my opinion it is harder to read/debug; using With statements makes it easier.
I had the code above looping through sheets in a workbook, but you can iterate through workbooks in a directory similarly.
Edit1:
In reading the comments and the updated post, I believe you're still working towards the use of lrd (last row on destination) +1, in the above code.
dim lrd as long, i as long, j as long
for i = 1 to workbooks(1).sheets.count
with ThisWorkbook.Sheets("Sheet2")
lrd = .cells(.rows.count,1).end(xlup).row
.range(.cells(lrd+1,1),.cells(lrd+1+10,1)).Values = Source.Sheets("SUMMARY DATA SHEET").Range(Source.Sheets("SUMMARY DATA SHEET").Cells(8,"A"),Source.Sheets("SUMMARY DATA SHEET").Cells(18,"A")).Value
do until j = (lrd+10+1)
if .Cells(lrd+1+j,1).Value = "" then .Cells(lrd+1+j,1).Value = "N/A"
loop
j = 0
end with
next i
The big addition here is to put arbitrary text into the unused cells so the last row definition will be easier. You could also eliminate the lrd by using a variable to count files, also elimnating the need to use the nested loop which fills in blank cells:
dim k as long
Do While myFile <> ""
'rest of your code using destination .range(.cells(1+k*10,1),.cells(1+10+k*10,1))
'directly before loop ends add
k = k + 1
Loop
k=0
Last note: I only showed for column 1 ("A") in my answer to demonstrate intent.
Edit2:
Declare up top:
dim k as long
Then using your existing loop, put inside like this (will need to add for the additional columns), which should only replace the section labeled 'Code :
with ThisWorkbook.Sheets("Sheet2")
.range(.cells(1+k+k*10,1),.cells(1+k+k*10+10,1)).Values = Source.Sheets("SUMMARY DATA SHEET").Range(Source.Sheets("SUMMARY DATA SHEET").Cells(8,"A"),Source.Sheets("SUMMARY DATA SHEET").Cells(18,"A")).Value
end with
Add these when closing your loop:
k = k + 1
Loop
k = 0
That should allow the k to iterate with the loop; k = 0 to start inherently, so your ranges are:
.range(.cells(1+0+0*10,1),.cells(1+0+0*10+10,1)).Values = A1 to A11 'first loop
.range(.cells(1+1+1*10,1),.cells(1+1+1*10+10,1)).Values = A12 to A22 'second loop
.range(.cells(1+2+2*10,1),.cells(1+2+2*10+10,1)).Values = A23 to A33 'third loop
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.