Having trouble running this code. i am not able to copy multiple columns from multiple workbooks and compile them into my worksheet. The columns will be of same name or same order in each file i am looping though. When I run this code I am not getting any result or error.
Option Explicit
Dim wsMaster As Workbook, csvFiles As Workbook
Dim Filename As String
Dim File As Integer
Dim r As Long
Public Sub Consolidate()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Title = "Select files to process"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Set wsMaster = ActiveWorkbook
For File = 1 To .SelectedItems.Count
Filename = .SelectedItems.Item(File)
If Right(Filename, 4) = ".csv" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = wsMaster.Sheets("Sheet1").UsedRange.Rows.Count
csvFiles.Sheets(1).Columns("col name").Copy Destination:=wsMaster.Sheets("Sheet1").Range("A" & r).Offset(1, 0)
csvFiles.Close SaveChanges:=False 'close without saving
End If
Next File 'go to the next file and repeat the process
End With
Set wsMaster = Nothing
Set csvFiles = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Related
In the below code i am able to fetch data from 1 file but i want to fetch the data from multiple excel files which i am selecting.
can anyone please help me how i can get through with it.
Sub CopySheet()
Application.ScreenUpdating = False
Dim flder As FileDialog
Dim FileName As String
Dim FileChosen As Integer
Dim wkbSource As Workbook
Dim wkbDest As Workbook
Set wkbDest = ThisWorkbook
OpenFile:
Set flder = Application.FileDialog(msoFileDialogFilePicker)
flder.Title = "Please Select an Excel File"
flder.InitialFileName = "c:\"
flder.InitialView = msoFileDialogViewSmallIcons
flder.Filters.Clear
flder.Filters.Add "Excel Files", "*.xlsm*"
MsgBox ("Select a folder and then a file to open.")
FileChosen = flder.Show
FileName = flder.SelectedItems(1)
Set wkbSource = Workbooks.Open(FileName)
wkbSource.Sheets("Sheet1").UsedRange.Copy
wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
wkbSource.Close savechanges:=False
If MsgBox("Do you want to open another workbook?", vbYesNo) = vbYes Then GoTo OpenFile
End Sub
Please, test the next updated code:
Sub CopySheet()
Dim flder As FileDialog, FileName As String, FileChosen As Integer
Dim wkbSource As Workbook, wkbDest As Workbook, i As Long
Set wkbDest = ThisWorkbook
OpenFile:
Set flder = Application.FileDialog(msoFileDialogFilePicker)
flder.Title = "Please Select Excel files"
flder.InitialFileName = "c:\"
flder.InitialView = msoFileDialogViewSmallIcons
flder.Filters.Clear
flder.Filters.Add "Excel Files", "*.xlsm" 'no need of ending *. Nothing can come after xlsm...
MsgBox ("Select a folder and then files to open and process.")
flder.AllowMultiSelect = True
FileChosen = flder.Show
If FileChosen = -1 Then
Application.ScreenUpdating = False
For i = 1 To flder.SelectedItems.count
FileName = flder.SelectedItems(i)
Set wkbSource = Workbooks.Open(FileName)
wkbSource.Sheets("Sheet1").UsedRange.Copy
wkbDest.Sheets("Master").cells(wkbDest.Sheets("Master").rows.count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
wkbSource.Close savechanges:=False
Next i
End If
Application.ScreenUpdating = True
If MsgBox("Do you want to process other workbooks?", vbYesNo) = vbYes Then GoTo OpenFile
End Sub
I am looping through a bunch of files in my folder and trying to copy a static column and paste to a master sheet. However every sheet I am looping through is a different name.
I believe this part of the code has to be changed:
xlsFiles.Sheets("Sheet3").Columns("20").Copy Destination:=wsMaster.Sheets("Sheet1").Range("A" & r).Offset(1, 0).
What can I use in place of sheets("Sheet3") ?
Here is the full code:
Option Explicit
Dim wsMaster As Workbook, csvFiles As Workbook
Dim Filename As String
Dim File As Integer
Dim r As Long
Public Sub Consolidate()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Title = "Select files to process"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Set wsMaster = ActiveWorkbook
For File = 1 To .SelectedItems.Count
Filename = .SelectedItems.Item(File)
If Right(Filename, 5) = ".csv*" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = wsMaster.Sheets("Sheet1").UsedRange.Rows.Count
csvFiles.Sheets(1).Columns("col name").Copy Destination:=wsMaster.Sheets("Sheet1").Range("A" & r).Offset(1, 0)
csvFiles.Close SaveChanges:=False 'close without saving
End If
Next File 'go to the next file and repeat the process
End With
Set wsMaster = Nothing
Set csvFiles = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The answer you already got by #sktneer in the comments above.
You could shorten and "clean-up" your If section code a little, try the code below:
If Right(Filename, 5) = ".xls*" Then
Set xlsFiles = Workbooks.Open(Filename, 0, True)
r = wsMaster.Sheets("Sheet1").UsedRange.Rows.Count
xlsFiles.Sheets(3).Columns("20").Copy Destination:=wsMaster.Sheets("Sheet1").Range("A" & r).Offset(1, 0)
xlsFiles.Close SaveChanges:=False 'close without saving
End If
Below is code that allows the user to choose a folder and opens files within the folder. It essentially does this:
On open, look for filepath saved in worksheet in workbook based on username. If doesn't exist, then prompt user to find folder, then save filepath in worksheet
From step 1, if filepath is found based on user, use that filepath
Error handler: From step 1, if filepath is found based on user, but that filepath is not in use anymore(i.e. user moved the folder to a different filepath), then have user find the folder again, then update existing record
What i'm experiencing is this:
When there's no entries in the sheet, then it will prompt user to
find the folder, but then proceed to the errorhandler and ask the
user to find the folder again
When there are entries in the sheet and the file path is working, the errorhandler is still opened and asks the user to find the
folder again
If I take out the errorhandler, everything is smooth. It's just that I want to cover the possibility of the user moving the folder , so I want the workbook to prompt the user to find where they moved the folder, and update the existing record in the workbook to the new path
What am I doing wrong here?
Private Sub Workbook_Open()
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim vafiles As Variant
Dim filepath As String
Dim filepath2 As String
Dim filepath3 As String
Dim rw As Long
Dim ws As Worksheet
Dim lastrow As Long
Dim icounter As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set ws = Worksheets("Paths")
rw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Extract")
'======================================================
'Determine if Path was already saved before. If not, prompt user to choose folder
'======================================================
sal = Application.VLookup(Environ("username"), ws.Range("a:b"), 2, 0)
If IsError(sal) Then
MsgBox ("Please choose where your main folder is located. This will be stored so you won't need to look for it again.")
filepath = PICK_A_FOLDER()
ws.Cells(rw, 2) = PICK_A_FOLDER()
ws.Cells(rw, 1) = Environ("username")
Set wkb2 = Workbooks.Open(filepath & "\ Export.xlsx")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic
Else
'======================================================
'If filepath exists, use that one
'======================================================
filepath2 = sal
Set wkb2 = Workbooks.Open(filepath2 & "Export.xlsx")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
End If
'======================================================
'If user has moved their folder, we can find it again and update their record
'======================================================
On Error GoTo Errorhandler
Errorhandler:
MsgBox ("Looks like you've moved your Folder. Please find it so your record will be updated")
filepath3 = PICK_A_FOLDER()
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For icounter = 2 To lastrow
If Cells(icounter, 1) = Environ("username") Then
Cells(icounter, 2) = PICK_A_FOLDER()
End If
Next icounter
Set wkb2 = Workbooks.Open(filepath3 & "")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic
End Sub
Actually solved this by taking out the errorhandler and inserting another if statement that captures an invalid directory:
if dir(sal & "Export.xlsx") = "" then
write error handler code
When a SubRoutine performs more that one task you should consider extracting the individual tasks into separate SubRoutines.
In this way:
You can debug each task independently of the other tasks
The logic is simplified into smaller units
The code is easier to read
You can reduce clutter by placing these SubRoutines into separate modules
Possible code reuse
Another unapparent benefit is that by simplifying the function of a SubRoutine it is much easier to remember the routines pattern and reuse the pattern when a similar situation arises.
Note: I often use If Len(...) then which is analogous to If Len(...) > 0 then. I do this to reduce clutter.
Standard Module
Function getSharedFolder() As String
Dim f As Range
With Worksheets("Paths")
Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
If Not f Is Nothing Then
'Dir([PathName], vbDirectory) returns empty if the [PathName] isn't a folder
If Len(Dir(f.Offset(0, 1).Value, vbDirectory)) Then
If Right(f.Offset(0, 1), 1) = "\" Then
getSharedFolder = f.Offset(0, 1)
Else
getSharedFolder = f.Offset(0, 1) & "\"
End If
End If
End If
End With
End Function
Function setSharedFolder() As Boolean
Dim f As Range
Dim PathName As String
PathName = PickSharedFolder
If Len(PathName) Then
setSharedFolder = True
With Worksheets("Paths")
Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
If f Is Nothing Then Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Offset(1)
f.Value = Environ("username")
f.Offset(0, 1) = PathName
End With
End If
End Function
Function PickSharedFolder() As String
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Folder"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select Main Folder Location"
If .Show = -1 And .SelectedItems.Count = 1 Then
PickSharedFolder = .SelectedItems(1)
Else: Exit Function
End If
End With
End Function
Sub ToggleEvents(EnableEvents As Boolean, Optional DisplayAlerts = True)
With Application
.DisplayAlerts = DisplayAlerts
.EnableEvents = EnableEvents
.ScreenUpdating = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Sub UpdateWorkBook(FilePath As String)
Dim WSSource As Worksheet
With Workbooks.Open(FilePath)
Set WSSource = .Sheets("Sheet1")
If WSSource Is Nothing Then
MsgBox "Sheet1 not found in " & FILENAME, vbCritical, "Update Cancelled"
Else
WSSource.Copy Destination:=ThisWorkbook.Sheets("Extract").Range("A1")
End If
.Close True
End With
End Sub
Workbook Module
Private Sub Workbook_Open()
Const FILENAME As String = "Export.xlsx"
Const PROMPT As String = "Press [Yes] to continue or [No] to cancel"
Dim FilePath As String, Title As String, SharedFolder As String
ToggleEvents False, False
Do
SharedFolder = getSharedFolder()
If Len(SharedFolder) = 0 Then
Title = "Folder not found"
Else
FilePath = SharedFolder & FILENAME
If Len(Dir(FilePath)) = 0 Then Title = "File not found"
End If
If Len(SharedFolder) = 0 Then
If MsgBox(PROMPT:=PROMPT, Buttons:=vbYesNo, Title:=Title) = vbYes Then
setSharedFolder
Else
Exit Sub
End If
End If
Loop Until Len(Dir(FilePath))
UpdateWorkBook FilePath
ToggleEvents True, 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
I just started using VBA and I've been using a code to merge multiple worksheets into a single workbook, it works fine except for worksheets containing images. In these cases the image won't show in the new workbook created. It appears the box where the image should be with an error message. I use MS Office 2010.
Here follows the code I've been using:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Any idea of what is going on? I'd appreciate any help!
Tks!
just found a workaround that helped!
I just added "Application.ScreenUpdating = True" before closing the source workbook, it takes longer to merge all worsheets, but at least the images are displayed correctly!
Here follows the new code:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
**Application.ScreenUpdating = True**
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Found this workaround here - Option 1!
Tks Dan!