I need some help on the following code, basically i have about 50 excel files in a folder and i want to copy data from each excel file to the master file. There are 3 worksheets in each file with the name 6D6 Cash, 6D6 Position and 6D6 Transactions and masterworkbook also has those tabs so for example macro will copy all the data from 6D6 cash worksheet in each excel file to the 6D6 cash worksheet in the master workbook and the new data will go below the last filled row. Also the row in each excel file has the header so that won't go in obviously.
For some reason, it's not working, as in the code is not working at all. What could be the reason?
Sub Adam1()
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim lLastRow As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbDst = ThisWorkbook
MyPath = "C:\Users\Adam\Desktop\6D6 files"
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(MyPath & strFilename)
'loop through each worksheet in the source file
For Each wsSrc In wbSrc.Worksheets
'Find the corresponding worksheet in the destination with the same name as the source
On Error Resume Next
Set wsDst = wbDst.Worksheets(wsSrc.Name)
On Error GoTo 0
If wsDst.Name = wsSrc.Name Then
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
wsSrc.UsedRange.Copy
wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
End If
Next wsSrc
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I think you have an incomplete string.
MyPath = "C:\Users\Adam\Desktop\6D6 files"
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Will be returning C:\Users\Adam\Desktop\6D6 filessomefile.xls
MyPath = "C:\Users\Adam\Desktop\6D6 files\" 'with the extra slash
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Related
I'm trying to:
Copy cell "B2:C2" from every workbook in a folder from the "Results" worksheet.
Paste the value into Cell A1:A2 Sheet1 in workbook "x"in the same folder.
I think I know how to open and do something to every workbook within a folder.
Option Explicit
Sub LoopThroughDirectory()
Dim MyFile As String
Dim WorkbookCounter As Long
WorkbookCounter = 1
Dim Filepath As String
Dim wb As Workbook
Dim RowCounter As Long
RowCounter = 1
Filepath = "C:\Test\"
Application.ScreenUpdating = False
MyFile = Dir(Filepath)
'Opens workbooks located C:\Test\ in order
Do While Len(MyFile) > 0
Set wb = Workbooks.Open(Filepath & MyFile)
Application.DisplayAlerts = False
'Copy cells B2 & C2 from the results worksheet
ThisWorkbook.Worksheets("x").Range(Cells(RowCounter, 1), Cells(RowCounter, 2)).Value = _
wb.Worksheets("Results").Range("B2:C2").Value
'Close wb most recently opened
wb.Close SaveChanges:=False
Application.CutCopyMode = False
WorkbookCounter = WorkbookCounter + 1
If WorkbookCounter > 1000 Then
Exit Sub
End If
MyFile = Dir
RowCounter = RowCounter + 1
Loop
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
Update: With help in the comments below the above code now correctly loops through the correct folder and updates cell A1:A2.
Instead of overwriting cell A1:A2 I'd like to paste the copied text one line down.
i.e. Workbook 1 = A1:A2, Workbook 2 = B1:B2, etc
I don't see any check to make sure you are not trying to open ThisWorkbook and there is no check to see if there is a Results worksheet in the source workbook; in fact there is no check to ensure that you are trying to open a workbook at all, you could be trying to open a JPG.
Further error control could be added to ensure that you are not trying to open another workbook that is already open. I suspect that after all the testing, you might have a few.
Option Explicit
Sub LoopThroughDirectory()
Dim myFile As String, filepath As String
Dim wbc As Long, ws As Worksheet, wb As Workbook
wbc = 0
filepath = "C:\Test\"
'Application.ScreenUpdating = False
'only try to open workbooks
myFile = Dir(filepath & "*.xls*")
'Opens workbooks located C:\Test\ in order
Do While Len(myFile) > 0
'make sure myFile isn't ThisWorkbook
If Split(myFile & ".", ".")(0) <> Split(ThisWorkbook.Name & ".", ".")(0) Then
Set wb = Workbooks.Open(Filename:=filepath & myFile, ReadOnly:=True)
'Application.DisplayAlerts = False
'check if there is a Results worksheet
On Error Resume Next
Set ws = wb.Worksheets("Results")
On Error GoTo 0
If Not ws Is Nothing Then
'transfer cells B2 & C2 from the results worksheet
With ws.Range("B2:C2")
ThisWorkbook.Worksheets("x").Range("A1").Offset(wbc, 0).Resize(.Rows.Count, .Columns.Count) = .Value
End With
End If
'Close wb most recently opened
wb.Close SaveChanges:=False
wbc = wbc + 1
If wbc > 1000 Then Exit Do
End If
Set ws = Nothing
myFile = Dir
Loop
ActiveWorkbook.Save
'Application.ScreenUpdating = True
End Sub
I am trying to copy data from multiple WB to one WB after using filter. I am able to select the copy range but I don't know how to paste them to the destination WB without making the data overwritten.
I am sorry for the format of my code. I do not know how to fix it when I post it here.
Here is my code:
Option Explicit
Const FOLDER_PATH = "D:\Programming\VBA\Linh\CARD DELIVERY\New folder\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
Dim rowCount As Long
rowTarget = 2
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheets("Sheet1")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
wsSource.Range("A2", Range("P" & Rows.Count).End(xlUp)).AutoFilter Field:=12, Criteria1:="Phát thành công"
wsSource.Range("I2", Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
rowCount = wsSource.Range("I2", Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells.Count
'import the data
With wsTarget
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
just add:
'import the data
wsTarget
.cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial
End With
to keep pasting filtered data in wsTarget column A from row 2 downwards
This macro loops through all the files in a directory and formats the data as a table.
I need to sort Column J on the table from Largest to Smallest and then save the file before moving onto the next file. Currently it leaves all the files open.
Sub LoopThroughFiles()
FolderName = "C:\Folder1\"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
Fname = Dir(FolderName & "*.xls")
'loop through the files
Do While Len(Fname)
With Workbooks.Open(FolderName & Fname)
Dim tbl As ListObject
Dim rng As Range
Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium2"
Columns("A:L").Select
Columns("A:L").EntireColumn.AutoFit
End With
'go to the next file in the folder
Fname = Dir
Loop
End Sub
You are missing the line where you Close the workbook : WB.Close True.
(if you don't want to save the changes made to the workbook use WB.Close False)
Note: you are not setting the Worksheet object on the workbook you open, so by default it will assume the ActiveSheet, which is the last ActiveSheet the last time you saved this workbook.
Try the code below:
Sub LoopThroughFiles()
Dim WB As Workbook
FolderName = "C:\Folder1\"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
fname = Dir(FolderName & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'loop through the files
Do While Len(fname)
Set WB = Workbooks.Open(FolderName & fname) '<-- set the workbook object
With WB
Dim tbl As ListObject
Dim rng As Range
Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium2"
Columns("A:L").Select
Columns("A:L").EntireColumn.AutoFit
End With
WB.Close True ' <-- close workbook and save changes
' go to the next file in the folder
fname = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I am trying to merge many excel files (workbooks) from a folder.
My problem is that I want to move different sheets to the new excel file.
At the moment my code can only move one sheet at the time from these different files.
Example:
I have 3 excel files named
1.xlsx
2.xlsx
3.xlsx
all 3 files have 3 sheets in it and I want to take sheet1 from 1.xlsx and sheet1 and sheet2 from 2.xlsx and finally sheet3 from 3.xlsx and put in a new excel file.
My code at the moment can only takes one sheet (and same sheet number) from each file and put in the new file.
My code so fare:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=path & "\" & Filename)
sheet = 1
Set wsSrc = wbSrc.Worksheets(sheet)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Many thank in advance
You need to loop through all the Sheets in the current Workbook found in your folder.
Try the code below:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(Path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=Path & "\" & Filename)
Sheet = 1
' ****** you need to loop on all sheets per Excel workbook found in Folder ******
For Each wsSrc In wbSrc.Sheets
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
Next wsSrc
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The background:
I have a directory containing multiple workbooks.
Each workbook contains multiple sheets, both hidden and visible.
I would like to copy one particular sheet from each workbook into an existing master workbook.
The problem:
At the moment, my code copies the first sheet in each source workbook.
I require the code to copy only the sheet called "[current month] Summary", which is most often not the first sheet in the source workbooks.
Because the [current month] will change, it needs to copy the sheet where the last seven letters of the name are "Summary".
My code as it stands:
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = InputBox("Please copy and paste the path to the folder containing the source documents")
Set wbDst = ActiveWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
Replace this line
Set wsSrc = wbSrc.Worksheets(1)
With
Set wsSrc = wbSrc.Worksheets("[current month] Summary")
Edit:
Replace your current Do Until Code with the below one :)
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
For Each ws In wbSrc.Worksheets
If InStr(1, ws.Name, "summary", vbTextCompare) Then
Set wsSrc = ws
End If
Next ws
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
Following code will get the current month and after checking the name in workbooks will give you the desired result:
Dim currMonth As String
currMonth = MonthName(Month(Now))
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
For Each ws In wbSrc.Worksheets
If ws.Name = currMonth & "Summary" Then
Debug.Print ws.Name
Set wsSrc = ws
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
Exit For
End If
Next
wbSrc.Close False
strFilename = Dir()
Loop