Excel VBA: Copy cells from specific workbook in loop to another - vba

I am new to VBA and am writing a macro. The purpose is to iterate through a list of spreadsheets (I have two sets saved in the same directory and each set has a specific naming convention). One set is named as "GenLU_xx" and the other is named as "LUZ_Summary_xx". The 'xx' in each name refers to a name e.g. Calgary. So I would have two different spreadsheets for Calgary (LUZ_Summary_Calgary & GenLU_Calgary).
The Macro needs to open each spreadsheet starting with "LUZ" add a value to G1. I have accomplished this first part by modifying code I found here: http://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder
The macro asks the user to identify the directory the spreadsheets are stored in and then loops through ones starting with "LUZ*".
The code is:
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "LUZ*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(fileName:=myPath & myFile)
'Add GEN_LU_ZN to column G1
wb.Worksheets(1).Range("G1").Value = "GEN_LU_ZN"
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
What I need for it to do from this point is copy two specific columns from each of the spreadsheets starting with "GenLU" and paste them into sheet 2 of the corresponding spreadsheet.
For example column C & E need to be copied from "GenLU_Calgary_2008" to the second sheet in the corresponding spreadsheet "LUZ_Summary_Calgary_2015". The code needs to somehow match up the spreadsheets using the name (in this case Calgary) and it needs to do this for all the spreadsheets.
Sorry for the extremely long question, but I'm hoping some can help a VBA newb out. I've searched quite a bit and while I have found the code to copy from sheet to sheet or workbook to workbook I am having trouble achieving what I need to. Any help will be much appreciated!

It is hard to test something without having any files, but you can try the following as part of your code:
Dim i As Integer
Dim wb1 As Workbook, wb2 As Workbook
Dim MyAr() As String: MyAr = Split("Calgary,XXX,YYY", ",")
For i = LBound(MyAr) To UBound(MyAr)
Do While myFile <> ""
If myFile Like "GenLU" & "*" & MyAr(i) Then
Set wb1 = Workbooks.Open(Filename:=myPath & myFile)
Exit Do
End If
Loop
Do While myFile <> ""
If myFile Like "LUZ_Summary" & "*" & MyAr(i) And Not wb1 Is Nothing Then
Set wb2 = Workbooks.Open(Filename:=myPath & myFile)
wb2.Worksheets(1).Columns(3).Value = wb1.Worksheets(1).Columns(3).Value
wb2.Worksheets(1).Columns(5).Value = wb1.Worksheets(1).Columns(5).Value
wb1.Close
wb2.Save
wb2.Close
Exit Do
End If
Loop
Set wb1 = Nothing
Next i
Note that you did not provide information which Worksheet you are working on, so I assume its always Worksheets(1). Column C = Columns(3). MyAr() is a String array to store the countries.

Related

Loop through all excel workbooks in a folder and convert all formulas to values

I am looking for a VBA code that would allow me to loop through all the Excel workbooks in a certain folder, and for each workbook will convert the cells in each worksheet from formulas to values.
Use the following code which loops through all the workbooks in a user-specified folder and does the following:
It opens the workbook
It loops within each worksheet in the workbook (including hidden worksheets), and converts to values every cell that contains a formula.
After performing the conversion, it saves and closes the workbook, and moves on to the next workbook in the folder.
See code below:
Sub LoopAllExcelFilesInFolderCancelFormulas()
'Purpose: To loop through all Excel files in a user specified folder and convert all formulas to values
Dim wb As Workbook
Dim ws As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Disable Excel Pop-up messages:
Application.DisplayAlerts = False
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For Each ws In wb.Sheets
ws.UsedRange.Value = ws.UsedRange.Value
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
The code for looping through all workbooks in a certain folder is based on the following code.

VBA Cell values as date range for file selection from folder

I hope you can help I currently have a piece of code (see below) that allows a user to select a folder. The code then opens up all the workbooks in that folder, selects a specific sheet, sheet named "SearchCaseResults" from each workbook book copies the data on this sheet and then pastes it to another sheet "Disputes" in another Workbook in another folder.
This all works perfectly, but what I want to happen now is that instead of opening up every workbook in the folder. I only want it to open up Workbooks in the folder based on the Cell Values of B6 and B7 which I have made into a Date Picker see Pic 1 for better understanding.
So instead of the piece of code that states do while folder is not blank
Do While myFile <> ""
I would like it to say something like
Do While myFile >= "B6" And myFile <= "B7"
The above piece of code compiles but does not work unfortunately
Can my code be amended to only open Workbooks in the date range set out in Cells B6 and B7
I have run out of online resources and have search for answers to this for days so I am reaching out for assistance
As always any and all help is greatly appreciated.
Pic 1
MY CODE
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Looper\"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = ThisWorkbook
Set ws2 = y.Sheets("Disputes")
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
With wb.Sheets("SearchCasesResults")
lRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
End With
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Pic of folder
If you're looking for files last modified between the dates in B6 and B7, then swap this into your current loop:
Do While myFile <> ""
If Int(FileDateTime(myPath & myFile)) >= Range("B6").Value And _
Int(FileDateTime(myPath & myFile)) <= Range("B7").Value Then
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
With wb.Sheets("SearchCasesResults")
lRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
End With
wb.Close SaveChanges:=True
End If
'Get next file name
myFile = Dir
Loop
If however, you wanted to compare the filename itself to the date in the cell, you're going to need to show us the filename's format for us to help.

Copy and paste data from multiple workbooks to a worksheet in another Workbook

I hope you can help. I currently have a piece of code see below. What I would like it to do is allow a user to select folder that contains workbooks. Then open each workbook select a sheet named "SearchCaseResults" from each workbook copy the data from each "SearchCaseResults" from the 2nd row down to the last used row, and paste this data into a worksheet called "Disputes" located in a different workbook in another folder.
So in PIC 1 you can see three Workbooks England, England_2 and England_3 each of these workbooks contain a worksheet "SearchCaseResults" So what I essentially need the code to do is loop through the folder open England workbook select the worksheet "SearchCaseResults" copy the data on this worksheet from row 2 to last used row then paste to the "Disputes" worksheet in the other workbook, in another folder, then select the next Workbook England_2 select the worksheet "SearchCaseResults" in this workbook copy the data on this worksheet from row 2 to last used row then PASTE IT BELOW the data copied from the previous worksheet(England) in the "Disputes" Worksheet and then continue with this copy and paste process until there are no more Workbooks left in the folder.
At the moment the code I have is opening up the workbooks, which is fine and selecting/activating the "SearchCaseResults" worksheet from each, but it is only coping cell A2 from the England sheets and then it is just pasting the data from the last sheet into the destination Worksheet.(I suspect the data from previous sheets is being pasted over) Can my code be amended to copy the data from each "SearhCaseResults" sheet from A2 to last used row and then Pasted into "Disputes" sheet underneath each other.
Here is my code so far as always any and all help is greatly appreciated.
CODE
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet\"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
Dim lRow As Long
Dim ws2 As Worksheet
lRow = Range("A" & Rows.Count).End(xlUp).Row
Set y = Workbooks.Open("C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet")
Set ws2 = y.Sheets("Disputes")
wb.Worksheets("SearchCasesResults").Range("A2" & lRow).Copy
With y
ws2.Range("A2").PasteSpecial
End With
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I should point out that the code above is run from a separate workbook with a command button.
See pic 2
PIC 1
PIC 2
Try this. I have corrected a few syntax errors. It's not clear if you are just copying data from column A, which I have assumed, but if not the copy line will need to be amended.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet\"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = Workbooks.Open("C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet")
Set ws2 = y.Sheets("Disputes")
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
With wb.Sheets("SearchCaseResults")
lRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
End With
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

How to copy specific cells and paste to a new workbook

Sub Button3_Click()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set newWb = Workbooks.Add
With newWb
.SaveAs Filename:=myPath & Left(myFile, 5) & "_import.xlsx"
End With
'Loop through each Excel file in folder
i = 2
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Set newWb = Workbooks.Open(Filename:=myPath & Left(myFile, 5) & "_import.xlsx")
'Change First Worksheet's Background Fill Blue
wb.Sheets("Textual elements").Range("J11").Copy _
Destination:=newWb.Sheets("Sheet1").Cells(i, 1)
wb.Worksheets("Textual elements").Range("J31").Copy _
Destination:=newWb.Worksheets("Sheet1").Cells(i, 2)
i = i + 1
'Save and Close Workbook
newWb.Close SaveChanges:=True
'Get next file name
myFile = Dir()
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
So I took the code from below site tried to edit according to my needs, but I get error italicized row in debugging mode.
The intention is to open a new workbook named as selected the folder and copy the cells to specific cells.
http://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder
The Range-object does not have a Paste method, so it cannot identify the Paste statement. Hence the error. You can use PasteSpecial though.
Try this:
replace:
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 1)).Paste
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 2)).Paste
with:
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2)).PasteSpecial
or without PasteSpecial:
wb.Worksheets("Textual elements").Range("J11").Copy newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2))
or even, if you must use Paste ;-):
wb.Worksheets("Textual elements").Range("J11").Copy
newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2)).select
ActiveSheet.Paste
I am still using Excel2002 so it doesn't play nice with xlsx files all the time. That said, you may not need the line
set newWb = Workbooks.Open(Filename:=myPath & Left(myFile, 5) & "_import.xlsx")
as I believe the workbook should open when it is added (possibly different in new versions).
When it comes to copying the range from one workbook to another
wb.Worksheets("Textual elements").Range("J11").Copy Destination:=newWb.Worksheets("Sheet1").Range(Cells(i, 1))
I am not sure if you have the Do While myFile <> "" loops set properly. You are ensuring myFile <> "" then doing something but not changing myFile's value and checking again that myFile <> ""
Also if you run this macro, it will overwrite the specified cells each time it is run so you will only have the most recent data - just incase that's not what you're trying to do.
EDIT
I still don't think you need to open the newwb when you have just opened it - might be best to step through the code using F8 & F9 to test that.
With regards the copying, I was right that you should use copy : destination, but hadn't noticed you were trying to range a cell. It should be either Range() OR cell(). Try this:
wb.Sheets("Textual elements").Range("J11").Copy _
Destination:=newWb.Sheets("Sheet1").Cells(i, 1)
wb.Worksheets("Textual elements").Range("J31").Copy _
Destination:=newWb.Worksheets("Sheet1").Cells(i, 2)
The space underscore ' _' at the end of copy is just to take the codee to a new line for ease of reading (so it doesn't go off the end of the page)
At the end of your code you are closing wb and saving changes even though you have not made any changes. I would change this to newwb and close wb without saving changes.

Create macro to output and update file after merging several excel files

I am a novice at VBA. I am using Excel 2013 for this task. I have several Excel files I am combining into a single file with multiple sheets using the macro below.
Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "H:\Survey Research\ECAS\Reports\2015\Tracks"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
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
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I want each sheet in the new file to take the name of its original file. I tried to edit the code below and include in the macro above, but while I didn't get an error message, it did not accomplish the task.
Do While fileName <> ""
Workbooks.Open (directory & fileName)
WrdArray() = Split(fileName, ".")
For Each sheet In Workbooks(fileName).Worksheets
Workbooks(fileName).ActiveSheet.Name = WrdArray(0)
total = Workbooks("import-sheets.xlsm").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy after:=Workbooks("import- sheets.xlsm").Worksheets(total)
Once the files have been merged and the sheets named, I want to output the new file and to easily update it if the data in my original files change.
Is it possible to achieve all of this with one macro? If so, could anyone suggest a way to write a Macro in Excel to automatically name the sheets, output the file and update it if changes are made to the data in the original files?
For the first part I think you only need to add one line:
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(FileName:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
'name the tab according to the file name
wsSrc.Name = Replace(strFilename,".xls","")
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
The last part about updating the workbook if the source files change is potentially much more complex: the easiest approach would be to re-run the consolidation code. If that doesn't work for you then you'd need to add more details on that.