crazy frog
New Member
- Joined
- Jul 21, 2011
- Messages
- 1
Hi, wondering if somebody can lend a hand with my query, I've written some code that reads/copys and pastes data from multiple workbooks in a specified folder to a master workbook starting in cell A2, the code works but i'm having trouble if i delete the information and re-run the code as it pastes it further down the worksheet and not back in Cell A2! I believe it's something stupid on my part so appologise now. Also if i update and save the multiple workbooks and re-run the code i have to re-run the code a number of times before it picks up the amendments
Any help greatly apprecited - Code is as follows
Private Sub getdata()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim wkbLastRow As Double
Dim wkb As Workbook
Dim wks As Worksheet
Dim dblLastRow As Double
Dim wkb_Copy2 As Workbook
Dim wks_Copy2 As Worksheet
Count = 1
'mycount = FoundFiles
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
'Change path to suit
With Application.FileSearch
.NewSearch
.LookIn = "C:\Users\Dave\Documents\test"
.FileType = msoFileTypeExcelWorkbooks
.Filename = "master.xls"
'Workbooks in folder
If .Execute > 0 Then
'Loop through all
For lCount = 1 To .FoundFiles.Count
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'location of master document to paste data
Set wkb_Copy2 = Workbooks("1master.xls")
Set wks_Copy2 = wkb_Copy2.Worksheets("sheet1")
'grab the data to be copied
Selection.Copy
Cells(Rows.Count, 1).End(xlUp).Row
'find out the last used row in the worksheet where the data is being copied to
dblLastRow = wks_Copy2.Cells.SpecialCells(xlLastCell).Row
'copy to 1 row below where the data ends [assume column A]
wks_Copy2.Range("A2" & dblLastRow).PasteSpecial xlPasteAll
'empty memory
Set wks_Copy2 = Nothing
Set wkb_Copy2 = Nothing
'Select data range to copy
Range("A1:O25").Select
Selection.Copy
'Paste append to a spreadsheet it finds the last used row and copies to the next row)
wkbLastRow = wks.Cells.SpecialCells(xlLastCell).Row
wks.Range("A" & dblLastRow + 1).PasteSpecial xlPasteAll
'empty memory
Set wks = Nothing
Set wkb = Nothing
ActiveWorkbook.Save
ActiveWorkbook.Close
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Any help greatly apprecited - Code is as follows
Private Sub getdata()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim wkbLastRow As Double
Dim wkb As Workbook
Dim wks As Worksheet
Dim dblLastRow As Double
Dim wkb_Copy2 As Workbook
Dim wks_Copy2 As Worksheet
Count = 1
'mycount = FoundFiles
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
'Change path to suit
With Application.FileSearch
.NewSearch
.LookIn = "C:\Users\Dave\Documents\test"
.FileType = msoFileTypeExcelWorkbooks
.Filename = "master.xls"
'Workbooks in folder
If .Execute > 0 Then
'Loop through all
For lCount = 1 To .FoundFiles.Count
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'location of master document to paste data
Set wkb_Copy2 = Workbooks("1master.xls")
Set wks_Copy2 = wkb_Copy2.Worksheets("sheet1")
'grab the data to be copied
Selection.Copy
Cells(Rows.Count, 1).End(xlUp).Row
'find out the last used row in the worksheet where the data is being copied to
dblLastRow = wks_Copy2.Cells.SpecialCells(xlLastCell).Row
'copy to 1 row below where the data ends [assume column A]
wks_Copy2.Range("A2" & dblLastRow).PasteSpecial xlPasteAll
'empty memory
Set wks_Copy2 = Nothing
Set wkb_Copy2 = Nothing
'Select data range to copy
Range("A1:O25").Select
Selection.Copy
'Paste append to a spreadsheet it finds the last used row and copies to the next row)
wkbLastRow = wks.Cells.SpecialCells(xlLastCell).Row
wks.Range("A" & dblLastRow + 1).PasteSpecial xlPasteAll
'empty memory
Set wks = Nothing
Set wkb = Nothing
ActiveWorkbook.Save
ActiveWorkbook.Close
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub