I have a folder named "Import" I want to fill up with xls files and import them all at once. The files have the same structure and just require an easy copy and paste to the last cell of my master sheet. With a specific file path it works, but I am not sure how to loop it.
Edit: I tried to implement the Loop. It worked once. After I deleted the data and tried to import them again, I run into 1004 errors, because the Script has a problem with the row "Set UserWorkbook = Application.Workbooks.Open(UserFilename)".
Do I have a logic issue here?
Sub Import_VDL_v2_Button()
'Disable features'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
'Set the target file for import.'
Dim TargetWorkbook As Workbook
Set TargetWorkbook = Application.ActiveWorkbook
'Specifing file directory.'
Dim UserFilename As String
UserFilename = Dir("/Users/Name/Documents/Reporting/Data/Import/" & "*.xls*")
'Start Loop for import.'
Do While Len(UserFilename) > 0
UserFilename = Dir
Dim UserWorkbook As Workbook
Set UserWorkbook = Application.Workbooks.Open(UserFilename)
'Define source and target sheet for copy.'
Dim SourceSheet As Worksheet
Set SourceSheet = UserWorkbook.Worksheets(1)
Dim TargetSheet As Worksheet
Set TargetSheet = TargetWorkbook.Worksheets(1)
'Check for filter and if present, clear all filter in source sheet.'
If SourceSheet.AutoFilterMode = True _
Then SourceSheet.AutoFilter.ShowAllData
'Unhide all rows and columns in source sheet'
SourceSheet.Columns.EntireColumn.Hidden = False
SourceSheet.Rows.EntireRow.Hidden = False
'Copy data from source to last row in target sheet.'
Dim SourceLastRow As Long
SourceLastRow = SourceSheet.Cells(SourceSheet.Rows.Count, "A").End(xlUp).Row
Dim TargetLastRow As Long
TargetLastRow = TargetSheet.Cells(TargetSheet.Rows.Count, "A").End(xlUp).Offset(1).Row
SourceSheet.Range("A2:S" & SourceLastRow).Copy
TargetSheet.Range("A" & TargetLastRow).PasteSpecial xlPasteValues
'Close import file and save active file.'
UserWorkbook.Close
ActiveWorkbook.Save
Loop
'Enable features'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
Related
I have a challenge on achieving the below project, kindly please assist:
I have four source workbooks with names(GK,SK,RJ and TB).
Each workbook(GK,SK,RJ and TB) have three worksheets with the same names(products, channels, and sales).
I have destination workbook called consolidated workbook with the same worksheets names(products, channels, and sales) like those of the four source workbooks.
All workbooks(source + destinations) are in the same folder.
Iam requesting VBA code that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Currently I have the below code but whenever I ran it copies everything from worksheets on the source workbooks and paste to worksheets in consolidated workbook which result to duplicated data.
All the source workbook have worksheets with the "DATE" as a first column in each worksheet table column.
Destination workbook also have the same worksheet names and the same columns structure on each worksheet are the same as of those source worksheet.
Kindly advise what should I amend so that the code will that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see the amended code:
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range,
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As
Range
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
On Error Resume Next
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
Set fndRng = sh.Range("A:A").Find(date_to_find,LookIn:=xlValues,
searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
On Error GoTo 0
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see how consolidated workbook appear(the sheet names and column format are exactly the same as of the source workbooks.)
CONSOLIDATED WORKBOOK
The following line can be used to find the latest date loaded on your consolidated sheet:
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
The following lines can be used on a worksheet (sh) to create a range (for copying) that starts after the latest_date_loaded down to the bottom of the table. You'll therefore need to ensure this is in date order.
Dim fndRng As Range, start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As Range
date_to_find = latest_date_loaded
Set fndRng = sh.Range("A:A").Find(date_to_find, LookIn:=xlValues, searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
EDIT
Here is a rework of your code, using some of the lines/ideas I've mentioned above.
Sub Copy_From_All_Workbooks()
'declarations
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, _
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As _
Range, latest_date_loaded As Date, consolidated_wb As Workbook
'turn off screen updating for user experience
'Application.ScreenUpdating = False
'set a reference to the consolidated workbook
Set consolidated_wb = ThisWorkbook
'read parent folder of consolidated workbook
wb = Dir(consolidated_wb.Path & "\*")
'perform this loop until no more files
Do Until wb = ""
'make sure it doesn't try to open consolidated workbook (again)
If wb <> consolidated_wb.Name Then
'open found source workbook
Workbooks.Open consolidated_wb.Path & "\" & wb
'cycle through each sheet (sh)
For Each sh In Workbooks(wb).Worksheets
'on that sheet, find the latest date already existing
latest_date_loaded = Application.WorksheetFunction.Max(consolidated_wb.Sheets(sh.Name).Range("A:A"))
'find the last occurence of that date in column A
Set fndRng = sh.Range("A:A").Find(latest_date_loaded, LookIn:=xlValues, _
searchdirection:=xlPrevious)
'if you find that date already then..
If Not fndRng Is Nothing Then
'set the top row to where you found it, plus one
start_of_copy_row = fndRng.Row + 1
Else
'otherwise, it's a new sheet, start on row two
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
'find the end of the table, using column A's contents
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
'make sure there's something to copy
If end_of_copy_row >= start_of_copy_row Then
'create a reference to the block of cells to copy
Set range_to_copy = sh.Range(start_of_copy_row & ":" & end_of_copy_row)
'copy that range
range_to_copy.Copy
'paste them, values only
consolidated_wb.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'clear copy markings from screen
Application.CutCopyMode = False
Else
'otherwise, do nothing here
End If
Next sh
'close the source workbook
Workbooks(wb).Close False
End If
'get next potential filename
wb = Dir
Loop
'turn back on screen updating
Application.ScreenUpdating = True
End Sub
This script loops through each value within a filtered column with the aim of filtering one by one, copy the data, create a new workbook, paste it and save it.
It it now creating a signle new workbook with all the worksheets, instead of one workbook per worksheet.
Can someone point out how can I mend the code to create one workbook per value filtered?
On the other hand, the workbook is also keeping the original sheet1. I am also looking on how to remove it, but thought it would be importat to let you know.
Sub test()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' -------------------
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
Dim ws As Worksheet
'Specify sheet name in which the data is stored
sht = "Report"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
Set ws = Workbk.Worksheets(sht)
'change filter column in the following code
last = ws.Cells(Rows.Count, "BR").End(xlUp).Row
With ws
Set rng = .Range("A1:BR" & last)
End With
ws.Range("G1:G" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BT1"), Unique:=True
For Each x In ws.Range([BT2], Cells(Rows.Count, "BT").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
newBook.Sheets.Add(After:=newBook.Sheets(newBook.Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' -------------------
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Check."
End Sub ```
Put the Workbooks.Add line inside the loop.
Option Explicit
Sub test()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsNew As Worksheet
Dim rng As Range, cel As Range
Dim iLastRow As Long, iLastRowBT As Long
Dim folder As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Workbook where VBA code resides
Set wb = ThisWorkbook
Set ws = wb.Sheets("Report")
folder = wb.Path & "\"
With ws
'change filter column in the following code
iLastRow = .Cells(Rows.Count, "BR").End(xlUp).Row
.Range("BT:BT").Clear
.Range("G1:G" & iLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("BT1"), Unique:=True
Set rng = .Range("A1:BR" & iLastRow)
iLastRowBT = .Cells(Rows.Count, "BT").End(xlUp).Row
End With
' create workbooks
For Each cel In ws.Range("BT2:BT" & iLastRowBT)
' Open New Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Sheets(1)
wsNew.Name = cel.Value
' filter and copy data
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=cel.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
' paste and save
wsNew.Paste
wbNew.SaveAs folder & cel.Value & ".xlsx"
wbNew.Close SaveChanges:=False
Next
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
MsgBox iLastRowBT - 1 & " Workbooks created in " & folder, vbInformation
End Sub
I'm new to VBA and I'm working on a project. I've searched around the internet and managed to put something together using others' examples. The basic idea is that the code copies user-selected data to a single master workbook. This is what I have so far;
Sub SelectOpenCopy()
Dim vaFiles As Variant
Dim i As Long
Dim DataBook As Workbook
Dim DataSheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
vaFiles = Application.GetOpenFilename(Title:="Select files", MultiSelect:=True)
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
Set DataBook = Workbooks.Open(FileName:=vaFiles(i))
For Each DataSheet In ActiveWorkbook.Sheets
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next DataSheet
DataBook.Close savechanges:=False
Next i
End If
End Sub
Two problems with this is that:
If I run the code again and select the same files, new worksheets are made in the master workbook and that isn't what I'm going for. If those worksheets already exist, I want them to be updated instead of new ones being made. If it helps to mention, all the workbooks that need to be copied to the master file only have one worksheet each and the worksheet name matches its workbook too.
The code copies all the data, but I only need a set range ("A1:L1000").
There's a lot I don't understand about VBA, so any and all help is really appreciated!
...
Const CopyAddress = "A1:L1000"
Dim MasterSheet As Worksheet, SheetName As String, SheetExists As Boolean
...
For Each DataSheet In DataBook.Worksheets
SheetName = DataSheet.Name
SheetExists = False
For Each MasterSheet In ThisWorkbook.Worksheets
If MasterSheet.Name = SheetName Then
SheetExists = True
Exit For
End If
Next MasterSheet
If SheetExists Then
DataSheet.Range(CopyAddress).Copy MasterSheet.Range(CopyAddress).Cells(1, 1)
Else
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next DataSheet
...
When you run it, don't forget to change the path for the target workbook.
Sub moveData()
'turn off unnecessary applications to make the macro run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim target_wb As Workbook
Dim main_wb As Workbook
Dim file_sheet As Worksheet
Dim exists As Boolean
Dim next_empty_row As Long
Dim R As Range
Dim sheet_name As String
Set main_wb = ThisWorkbook
Set R = _
Application.InputBox("please select the data range:", "Kutools for Excel", , , , , , 8)
sheet_name = ActiveSheet.Name
R.Select
Selection.copy
'workbook path to paste in
Set target_wb = _
Workbooks.Open("/Users/user/Desktop/target.xlsx")
For Each file_sheet In target_wb.Sheets
Application.DisplayAlerts = False
If file_sheet.Name = main_wb.ActiveSheet.Name Then
exists = True
Exit For
Else
exists = False
End If
Next file_sheet
If exists = False Then
target_wb.Sheets.Add.Name = sheet_name
End If
next_empty_row = _
target_wb.Sheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row + 1
target_wb.Sheets(sheet_name).Cells(next_empty_row, 1).PasteSpecial
target_wb.Save
target_wb.Close
'turn on applications
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
I have zone wise data in different excel. I want to create a macro to merge all excel files in a new worksheet.
I have tried below code but it is not working.
Sub CopyBooks()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim destinationWorkbook As Workbook
Set destinationWorkbook = ThisWorkbook
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim sourceWorkbook As Workbook
Dim sourceWorksheet As Worksheet
Const path As String = "C:\Corporate Competition\Excel\merge\"
Dim file As Variant
Dim currentSheets As Long
currentSheets = destinationWorkbook.Sheets.Count
file = Dir(path & "**.xls**")
While file <> ""
Set sourceWorkbook = Workbooks.Open(path & file)
For Each sourceWorksheet In sourceWorkbook.Worksheets
sourceWorksheet.Copy
lCopyLastRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, "A").End(xlUp).Row
lDestLastRow = currentSheets.Cells(ThisWorkbook.Rows.Count, "A").End(xlUp).Offset(1).Row
sourceWorksheet.Range("A2:D" & lCopyLastRow).Copy _
ThisWorkbook.Range("A" & lDestLastRow)
Next
sourceWorkbook.Close savechanges:=False
file = Dir
Wend
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
I want all files to append one after another. Also, a column name to indicate the zone name/excel file name will be of great help.
I am copying a range from all open workbooks with the goal of pasting the copied cells into a consolidated sheet in the master (active) workbook. I need to paste the values only but get an "end of line" error message with this code
Spent pretty much all day googling my problem to no avail
Sub Consolidate()
Dim oBook As Workbook, ws As Worksheet, wb As Workbook, bk As Workbook
Dim copyFrom As Range
'Disable Screen Updating - stop screen flickering
' And Disable Events to avoid inturupted dialogs / popups
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True
'Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
DstSht.Name = "Consolidate_Data"
End With
'Loop through each WorkBook in the folder and copy the data to the 'Consolidate_Data' WorkSheet in the ActiveWorkBook
Set wb = ActiveWorkbook
For Each oBook In Application.Workbooks
If Not oBook.Name = wb.Name Then
'Find the last row on the 'Consolidate_Data' sheet
DstRow = fn_LastRow(DstSht) + 1
'Determine Input data range
Set copyFrom = oBook.Worksheets(1).Range("A6:C8")
'Copy data to the 'consolidated_data' WorkSheet
copyFrom.Copy _
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
End If
Next
IfError:
'Enable Screen Updating and Events
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
'Find the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
Dim lastRow As Long
lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
lRow = Sht.Cells.SpecialCells(xlLastCell).Row
Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop
fn_LastRow = lRow
End Function
Consolidate()
Dim oBook As Workbook, ws As Worksheet, wb As Workbook, bk As Workbook
Dim copyFrom As Range
'Disable Screen Updating - stop screen flickering
' And Disable Events to avoid inturupted dialogs / popups
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True
'Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
DstSht.Name = "Consolidate_Data"
End With
'Loop through each WorkBook in the folder and copy the data to the 'Consolidate_Data' WorkSheet in the ActiveWorkBook
Set wb = ActiveWorkbook
For Each oBook In Application.Workbooks
If Not oBook.Name = wb.Name Then
'Find the last row on the 'Consolidate_Data' sheet
DstRow = fn_LastRow(DstSht) + 1
'Determine Input data range
Set copyFrom = oBook.Worksheets(1).Range("A6:C8")
'Copy data to the 'consolidated_data' WorkSheet
copyFrom.Copy _
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
End If
Next
IfError:
'Enable Screen Updating and Events
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
'Find the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
Dim lastRow As Long
lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
lRow = Sht.Cells.SpecialCells(xlLastCell).Row
Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop
fn_LastRow = lRow
End Function
Get an error message at the PasteSpecial line. Everything works fine without the paste special but, as the copied range includes formulas, I do not get the values which is what I need.
.Copy and .PasteSpecial have to be done in 2 different lines but you concatenated the lines with _
copyFrom.Copy _
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
Change it to:
copyFrom.Copy 'no line concatenation here !
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
For more information see the documentation:
Range.Copy method
Range.PasteSpecial method / Worksheet.PasteSpecial method