I'm struggling with my code to copy data from 3 workbooks with same worksheet name to one master workbook also having the same name. The main problem is to define the last row. After I copy the first data set from the first workbook and then go to second one I want to paste the data below the first data in master workbook and so on. Do you guys have any suggestions?
Below is my unfinished code:
Sub refresh()
Dim wball, wb1, wb2, wb3 As Workbook
Dim ws, sht As Worksheet
Dim wbpath As String
Dim LastRow As Long
Application.ScreenUpdating = False
wbpath = Application.ThisWorkbook.Path
'wball = ThisWorkbook 'master workbook
Application.DisplayAlerts = False
'clears master wb
Set ws = ThisWorkbook.Worksheets("Tab")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
ws.Rows(3).ClearContents
'ws.Rows("3:" & LastRow).Delete
ws.Range("Tab").Delete
Set wb1 = Workbooks.Open(wbpath & "\file1.xlsm")
LastRow = wb1.Sheets("Tab").Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A3:CD" & LastRow).Value = wb1.Sheets("Tab").Range("A3:CD" & LastRow).Value
Set wb2 = Workbooks.Open(wbpath & "\file2.xlsm")
LastRow = wb2.Sheets("Tab").Cells(ws.Rows.Count, "A").End(xlUp).Row
'ws.
ws.Range("A3:CD" & LastRow).Value = wb2.Sheets("Tab").Range("A3:CD" & LastRow).Value
wb1.Close SaveChanges:=False
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Ok, I have made some changes and everything is working now as it should be.
Sub refresh()
Dim masterwb As Workbook
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim wb3 As Workbook
Dim masterws As Worksheet
Dim ws As Worksheet
Dim wbpath As String
Dim LastRow As Long
Dim LastRowSource As Long
Dim LastRowDestination As Long
Application.ScreenUpdating = False
wbpath = Application.ThisWorkbook.Path
'masterwb = ThisWorkbook
Application.DisplayAlerts = False
'clears master wb
Set masterws = ThisWorkbook.Worksheets("Tab")
'LastRow = masterws.Cells(ws.Rows.Count, "A").End(xlUp).Row
masterws.Rows(3).ClearContents
masterws.Range("A4:CD9999").Delete
'start to copy data from 3 workbooks
Set wb1 = Workbooks.Open(wbpath & "\file1.xlsm")
LastRowDestination = wb1.Sheets("Tab").Cells(Rows.Count, "A").End(xlUp).Row
masterws.Range("A3:CD" & LastRowDestination).Value = wb1.Sheets("Tab").Range("A3:CD" & LastRowDestination).Value
LastRowSource = masterws.Cells(masterws.Rows.Count, "A").End(xlUp).Row + 1
'LastRowSource + LastRowDestination -3 because im getting 3 extra rows with #N/D
Set wb2 = Workbooks.Open(wbpath & "\file2.xlsm")
LastRowDestination = wb2.Sheets("Tab").Cells(Rows.Count, "A").End(xlUp).Row
masterws.Range("A" & LastRowSource & ":CD" & LastRowSource + LastRowDestination -3).Value = wb2.Sheets("Tab").Range("A3:CD" & LastRowDestination).Value
LastRowSource = masterws.Cells(masterws.Rows.Count, "A").End(xlUp).Row + 1
Set wb3 = Workbooks.Open(wbpath & "\file3.xlsm")
LastRowDestination = wb3.Sheets("Tab").Cells(Rows.Count, "A").End(xlUp).Row
masterws.Range("A" & LastRowSource & ":CD" & LastRowSource + LastRowDestination -3).Value = wb3.Sheets("Tab").Range("A3:CD" & LastRowDestination).Value
wb1.Close SaveChanges:=False
wb2.Close SaveChanges:=False
wb3.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Thanks for your help.
Related
I have multiple workbooks in a folder and i need to copy paste data from some of them based on naming convention. I am copy pasting data based on column names to a master sheet as order of columns in source files is not the same. Code pasted below does the task but it looks for exact match in column names and as a result i am only able to capture 80% of the data as few column names in source files are not an exact match. For eg: A column in the Target file with header Premium is mentioned as Premium # 25% in the Source file. This is just an example.
Sub ImportExcelfiles()
Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long
Dim colCountSource As Long
Dim rowOutputTarget As Long
Dim colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long, Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim fileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'====================================
'SET THE PATH AND FILE TO THE FOLDER
'====================================
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target worksheet
Set wsTarget = ThisWorkbook.Worksheets("Master Data")
Set bookName = ThisWorkbook.Worksheets("Workbook Name")
'set the initial output row and column count for master data and workbook name
nameCount = 2
rowOutputTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile)
Set wsSource = wbSource.Worksheets("Details")
'get the row and column counts
With wsSource
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
For j = 1 To colCountSource
Cr1 = .Cells(2, j).Value
Set srcRow = .Range("A2", .Cells(1, colCountSource))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=True)
If Not found1 Is Nothing Then
colCountSource = wsTarget.Cells(1, Columns.Count).End(xlToLeft).Column
Set srcRow = wsTarget.Range("A1", wsTarget.Cells(1, colCountSource))
Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=F)
If Not found2 Is Nothing Then
rowCountSource = .Cells(Rows.Count, found1.Column).End(xlUp).Row
.Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column)).Copy
found2.Offset(rowOutputTarget, 0).PasteSpecial Paste:=xlPasteValues
End If
End If
Next j
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = rowOutputTarget + rowCountSource - 2
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation
End Sub
This code takes approximately 5 mins to copy paste data. Is there a way to optimise it and also solve my problem of missing 20% data.
Because the target column name is the shorter you need to search the source column names for each target column name.
Option Explicit
Sub ImportExcelfiles()
Dim strPath As String, strFile As String, fileName As String
Dim wbSource As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long, colCountSource As Long
Dim colCountTarget As Long
Dim rowOutputTarget As Long, colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long
Dim Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim t0 As Single: t0 = Timer
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
'set the target worksheet
With ThisWorkbook
Set wsTarget = .Sheets("Master Data")
Set bookName = .Sheets("Workbook Name")
End With
'set the initial output row and column count
'for master data and workbook name
nameCount = 2
Dim arTarget, rngSrc As Range, rngTarget As Range
Dim lastrow As Long, n As Long
With wsTarget
rowOutputTarget = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
' array of target column names
colCountTarget = .Cells(1, .Columns.Count).End(xlToLeft).Column
arTarget = .Cells(1, 1).Resize(, colCountTarget)
End With
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Application.ScreenUpdating = False
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile, ReadOnly:=True)
Set wsSource = wbSource.Worksheets("Details")
With wsSource
'get the row and column counts'get the row and column counts
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
Set srcRow = .Range("A2", .Cells(1, colCountSource))
' loop through target columns
For j = 1 To UBound(arTarget, 2)
Cr1 = arTarget(1, j)
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlPart, MatchCase:=True)
' found
If Not found1 Is Nothing Then
rowCountSource = .Cells(.Rows.Count, found1.Column).End(xlUp).Row
n = rowCountSource - 2
Set rngSrc = .Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column))
Set rngTarget = wsTarget.Cells(rowOutputTarget, j)
rngTarget.Resize(n).Value2 = rngSrc.Value2
If lastrow < rowOutputTarget + n Then
lastrow = rowOutputTarget + n
End If
End If
Next
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = lastrow
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Hi I have the following code which loops through dropdown selections and saves each result as a new workbook based on the named range in cell G3. I am trying to edit the code so that it saves all the worksheets to the new file instead of just the active one, if anyone could help? thank you
Sub myFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim nwb As Workbook
Dim nws As Worksheet
Dim rng As Range
Dim Path As String
Dim myDate As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
Path = "C:\Users\bradley\Desktop\Sales by Month\"
myDate = Format(Now(), "MM-DD-YYYY")
For i = 1 To 4
rng = ws.Range("J" & i)
ws.Copy
Set nwb = ActiveWorkbook
Set nws = nwb.Worksheets("Summary")
With nws
Cells.Copy
Cells.PasteSpecial (xlPasteValues)
End With
Application.DisplayAlerts = False
nwb.SaveAs FileName:=Path & rng & " " & myDate & ".xlsx",
FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
End Sub
Loop through the sheets but only create a workbook on the first one.
Option Explicit
Sub myFiles()
Const FOLDER = "C:\Users\bradley\Desktop\Sales by Month\"
Dim wb As Workbook, nwb As Workbook
Dim ws As Worksheet, rng As Range
Dim myDate As String, i As Long, j As Long
Dim filename As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
myDate = Format(Now(), "MM-DD-YYYY")
Application.ScreenUpdating = False
For i = 1 To 4
rng.Value2 = ws.Range("J" & i).Value2
' copy all sheets
For j = 1 To wb.Sheets.Count
If j = 1 Then
wb.Sheets(j).Copy
Set nwb = ActiveWorkbook
Else
wb.Sheets(j).Copy after:=nwb.Sheets(j - 1)
End If
With nwb.Sheets(j)
.UsedRange.Value2 = .UsedRange.Value2
End With
Next
' save workbook
filename = FOLDER & rng.Value2 & " " & myDate & ".xlsx"
Application.DisplayAlerts = False
nwb.SaveAs filename:=filename, FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
When trying to copy range("A2:H2") + End(xlDown) from multiple files into master Workbook
Run time error '424' Object Required
Sub Create()
Dim folderPath As String
Dim fileName As String
Dim erow As Long
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
folderPath= "\\Groups\DAILY RECON\October 2021"
Set wbMaster = ActiveWorkbook
Set wsMaster = wbMaster.Sheets("NY")
if Right(folderPath, 1)<> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.xlsm")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Do While fileName<>""
if fileName <> "master.xlsm" Then
Set wbTemp = Workbooks.Open(folderPath & fileName, ReadOnly= True)
Set wsTemp = wbTemp.Sheets("NY")
With wsMaster
erow = .Range("A" & .Rows.Count).End(xlUp).Row
ws.Temp.Range("A2:H2").Select ' ----> **Error**
Range(ActiveCell,ActiveCell.End(xlDown)).Select
Selection.Copy
.Range("A" & erow).Offset(1,0).PasteSpecial xlPasteValues
End With
wbTemp.Close False
Set wsTemp = Nothing
Set wbTemp = Nothing
End If
fileName = Dir
Loop
MsgBox "Finished"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Copy Range From Multiple Files
Option Explicit
Sub Create()
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
Dim mrg As Range, trg As Range
Dim mrrg As Range
Dim meRow As Long
Dim mFileName As String, tFileName As String
Dim tFolderPath As String
Dim rCount As Long
Dim cCount As Long
tFolderPath = "\\Groups\DAILY RECON\October 2021"
Set wbMaster = ActiveWorkbook ' ThisWorkbook ' workbook containing this code
Set wsMaster = wbMaster.Sheets("NY")
With wsMaster
meRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
cCount = wsMaster.Columns("A:H").Columns.Count
Set mrrg = .Range("A" & meRow).Resize(, cCount)
End With
mFileName = wbMaster.Name
If Right(tFolderPath, 1) <> "\" Then tFolderPath = tFolderPath & "\"
tFileName = Dir(tFolderPath & "*.xlsm")
Application.ScreenUpdating = False
Do While tFileName <> ""
If StrComp(tFileName, mFileName, vbTextCompare) <> 0 Then
Set wbTemp = Workbooks.Open(tFolderPath & tFileName, ReadOnly:=True)
On Error Resume Next ' check if exists
Set wsTemp = wbTemp.Sheets("NY")
On Error GoTo 0
If Not wsTemp Is Nothing Then ' it exists
With wsTemp.Range("A1").CurrentRegion.Columns("A:H")
Set trg = .Resize(.Rows.Count - 1).Offset(1)
End With
rCount = trg.Rows.Count
Set mrg = mrrg.Resize(rCount)
mrg.Value = trg.Value
Set mrrg = mrrg.Offset(rCount)
Set wsTemp = Nothing
End If
wbTemp.Close SaveChanges:=False
End If
tFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Finished"
End Sub
I have code like that:
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim LastRow As Long
Set wsCopy = Workbooks("file1.xlsm").Worksheets("Order")
Set wsDest = Workbooks("orders.xlsm").Worksheets("All Data")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(0).Row
wsCopy.Range("A1:I9" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
LastRow = Sheets("All Data").UsedRange.Rows.Count
Sheets("All Data").Range("L" & lDestLastRow).Value = "order made?:"
Sheets("All Data").Range("L" & lDestLastRow + 1).Value = "Yes/No"
Range("L" & lDestLastRow).Font.Bold = True
wsDest.Activate
In place where i have Workbooks("file1.xlsm") i want pick file to copy.
It is possible using Workbooks or any other method?
With the GetOpenFilename-method, Workbooks.Open and replacing your string with the variable:
Dim selectedFilename As Variant
selectedFilename = Application.GetOpenFilename(FileFilter:=”Excel Files,*.xl*;*.xm*”)
If selectedFilename <> False Then
Workbooks.Open FileName:=selectedFilename
End If
Set wsCopy = Workbooks(Mid$(selectedFilename, InStrRev(selectedFilename, "\") + 1)).Worksheets("Order")
I have the following code:
Sub export_toFEP2()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim x As String, lastrow As String
Dim lRow As Long, kRow As Long, i As Long
Dim u As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ThisWorkbook.Activate
Sheets("FEP Selection").Activate
u = Sheets("FEP Selection").Range("File_Name").Value2
Set wb = Workbooks(u)
Set ws = wb.Worksheets("Ship Arrivals")
Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("FEP copy")
lastrow = ws2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If ws2.Range("D" & i).Value = "TRUE" Then
lRow = Application.WorksheetFunction.Match(ws2.Range("A" & i).Value2, ws.Range("A2:CS2"), 0)
kRow = Application.WorksheetFunction.Match(CLng(ws2.Range("B" & i).Value), ws.Range("A1:A145"), 0)
If lRow > 0 And kRow > 0 Then
MsgBox lRow
MsgBox kRow
ws.Cells(kRow, lRow).Value = ws2.Range("C" & i).Value
End If
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The problem i am having is that it does not do anything but does not give any errors either.
the variable should pick up a value like "A.xls" (that's the value of file name range), it changes every time, hence, i have a range with the file name.
if i change to the
Set wb = Workbooks(u)
to
Set wb = Workbooks("A1.xls")
it seems to work, but that defeats the purpose as the file name is variable.
thank you for your help :)
If the workbook in question is open, omit the .xls when you set the value of wb.
Something like:
Set wb = Workbooks(Replace(u, ".xls", ""))