Trying to use Excel VBA to combine data together from multiple spreadsheets, but my loop keeps saving over previously saved data - vba

I found a website that has a macro that lets you complete a looped action for all spreadsheets in a file folder. I've used this macro as the basis for my macro below: See Link Here
I've been able to use it successfully for a few other projects, but I'm running into some issues on my current project. I have a number of spreadsheets in a file folder that I'm attempting to open, copy the data, then paste into a master spreadsheet. The goal is to put all the data from the many spreadsheets, into one singular spreadsheet. The list of the many spreadsheets in the file folder is a dynamic list that will change over time. So I can't simply individually reference every spreadsheet, that's why I'm trying to use the looping strategy from the link above.
The problem I'm having is some of the pastes are getting pasted over previous spreadsheet's values. So instead of each spreadsheet getting pasted at the bottom of the previous's values, some are getting pasted in the middle and overwriting information that I need. I think my problem is that excel is getting confused as to which spreadsheet should be referenced when I gets into the row.count, copy/paste section of the code and the variables for i & j are getting assigned incorrectly. But I can't figure out how to fix this. I'm out of ideas, and thoroughly frustrated! Apologies if I'm screwing up something rather basic, but I'm rather new to VBA.
Sub CombineReports()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim i As Integer
Dim j As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
myPath = "I:\Pricing\mt access\Tier Reports\Final Reports\"
'Target Path with Ending Extention
myFile = Dir(myPath)
'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
'Worksheet tasks
i = wb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
wb.Worksheets(1).Range("A5", "N" & i).Copy
Workbooks.Open ("I:\Pricing\mt access\Tier Reports\Final Reports\Combined Report\CombinedTierReport.xlsx")
j = Workbooks("CombinedTierReport.xlsx").Worksheets("AllStores").Range("B" & Rows.Count).End(xlUp).Row
Workbooks("CombinedTierReport.xlsx").Worksheets("AllStores").Range("A" & j + 1, "N" & i).PasteSpecial xlPasteValues
Workbooks("CombinedTierReport.xlsx").Save
Workbooks("CombinedTierReport.xlsx").Close
DoEvents
'Save and Close Workbook
Application.DisplayAlerts = False
wb.Close SaveChanges:=False
Application.DisplayAlerts = True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Change Range("A" & j + 1, "N" & i) to Range("A" & j + 1). a) the range is wrong and b) you only need the top-left cell of a paste.
...
i = wb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
wb.Worksheets(1).range("A5", "N" & i).Copy
with Workbooks.Open ("I:\Pricing\mt access\Tier Reports\Final Reports\Combined Report\CombinedTierReport.xlsx")
j = .Worksheets("AllStores").Range("B" & Rows.Count).End(xlUp).Row
.Worksheets("AllStores").Range("A" & j + 1).PasteSpecial xlPasteValues
.Save
.Close savechanges:=false
end with
...

Related

Copy and Paste VALUES from multiple workbooks to a worksheet in another workbook / Paste Value within Loop

The heavy lifting of this problem has already been solved here:
Copy and paste data from multiple workbooks to a worksheet in another Workbook
After adapting the code, I got everything to work perfectly in about 15 minutes. However, I then spent the past 3 hours scouring stackoverflow and the rest of the internet trying to figure out how to get it to paste VALUES ONLY instead of bringing over the formatting and formulas with it.
I've tried using .PasteSpecial xlPasteValues, but every time I try this I get an error that says "Compile Error: Expected: end of statement"
I've also tried using .PasteSpecial(xlPasteValues), I get an error that says "Run-time error '1004': Unable to get the PasteSpecial property of the Range class"
My concern is that neither of these methods will work since there wasn't even a .Paste function to begin with.
So when I tried to just add .Paste, it gives me a "Run-time error '438': Object doesn't support this property or method"
Here's the whole code, but I'm mainly just trying to figure out how to do exactly the same with except pasting VALUES ONLY. Thanks!
Sub ConsolidateAllOrdenes()
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 = "Choose Target Folder Path"
.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 = "*.xlsm*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = Workbooks.Open("C:\Consolidado\Consolidado_2018-09-05a.xlsm")
Set ws2 = y.Sheets("Consolidado_Orden")
'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 "Orden de Compras" sheet to "consolidado_orden" Sheet in other workbook
With wb.Sheets("Orden de Compras")
lRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("A5:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "I hope that worked!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Replace your copy/paste with this:
With wb.Sheets("Orden de Compras")
Range("A2:M" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Sorry, I'm new to this, but I think I finally figured it out. I believe the range with the copy was lacking a defined workbook and sheet.
Once I specified the workbook and sheet for the copy, there was no issue with putting the paste range on another line and adding .PasteSpecial Paste:=xlPasteValues.
I was also copying 2 lines from each workbook that didn't actually have anything, so I added If WorksheetFunction.CountA(wb.Sheets("Orden de Compras").Range("C5:C200")) <> 0 Then and later Else and End If to skip that workbook if it didn't have anything within the range C5:C200.
I also added Application.CutCopyMode = False because a message box kept popping up after each file.
Replace the copy/paste with this:
With wb.Sheets("Orden de Compras")
If WorksheetFunction.CountA(wb.Sheets("Orden de Compras").Range("C5:C200")) <> 0 Then
lRow = .Range("C" & Rows.Count).End(xlUp).Row
wb.Sheets("Orden de Compras").Range("A5:M" & lRow).Copy
ws2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Else
End If
End With
Thanks to everyone and especially #GMalc for the help!!!

Macro to copy certain cells from one workbook to another and append data

I am trying to create a macro to copy certain cells from one workbook to another. I need to append the new data to data that has already been transferred. I am trying to modify this code to do so, but am not having success:
Sub Consolidate()
'Author: Jerry Beaucaire'
'Date: 9/15/2009 (2007 compatible) (updated 4/29/2011)
'Summary: Merge files in a specific folder into one master sheet (stacked)
' Moves imported files into another folder
' Edited/altered by Jay Chase 6/9/2017
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("BM Condition") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
fPath = "C:\Users\jchase.BRYCEWORLD\Desktop\Test\" 'remember final \ in this string"
fPathDone = fPath & "Imported\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*New BM Analysis 3.xls") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
LR = Range("A" & Rows.Count).End(xlUp).Row 'Find last row
Range("P14:S" & LR).EntireRow.Copy .Range("A" & NR)
wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
End If
fName = Dir 'ready next filename
Loop
End With
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
I have little experience with VBA. Any help with how or why or why not I can do this is appreciated. I am still experimenting; if I have any breakthroughs I will update.
EDIT: so i have realized this code has to be called from the workbook i want to write to, but i need to call it from the workbook i am reading from. Is there a way to modify this script to do so?

Code to merge data in multiple documents by column

Is there a way to merge the data in multiple excel spreadsheets together by column?
I have 200 spreadsheets, each with text in the first 100 columns (A-CV).
I would like to merge all the "A" columns from these 200 documents together, all the "B" columns together, all the "C" columns together, and so on.
As for the merging, no particular order is required. As long as the cells themselves don't get merged.
Due to the large amount of text the code would be merging, it would be more practical to be able to merge one column at a time across all spreadsheets into a unique file, then repeat that with all other columns (A-CV), instead of attempting to merge all the columns (from all spreadsheets) together into one single file.
I found a code that merges columns, but it's not quite what I need. Is there a way to modify this code to help with what I described above?
Sub Macro1()
'
' Macro1 Macro
'
Dim cell As Range
For i = 1 To 50
Sheets("Sheet1").Select
If Cells(1, i).Value = "Cat 2" Then
Columns(i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
End If
If Cells(1, i).Value = "Cat 6" Then
Columns(i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B1").Select
ActiveSheet.Paste
End If
If Cells(1, i).Value = "Cat 4" Then
Columns(i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C1").Select
ActiveSheet.Paste
End If
Next i
End Sub
If you need more information, please let me know. And if I need to rename the documents a certain way to help with the process, I'm definitely willing to do that.
The merged data can be sent to a spreadsheet, word document, or notepad. I'm fine with any of these options.
UPDATE: This is the new code with modifications. The issues I am having are in the comment below.
Sub copydocument()
Dim wb As Workbook
Dim wb1 As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo resetsettings
Set wb = ThisWorkbook
MyPath = "C:\Users\HNR\Desktop\A\" 'Path of folder with \ at the end
MyExtension = "*.xlsx"
Myfile = Dir(MyPath & MyExtension)
While Myfile <> vbNullString
Set wb1 = Workbooks.Open(MyPath & Myfile)
lr = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
lr1 = wb1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
wb1.Sheets(1).Range("A" & lr1).Copy Destination:=wb.Sheets(1).Range("A" & (lr + 1))
wb1.Close
Myfile = Dir
Wend
resetsettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
While there are many ways to do what you want, I would recommend looking into Power Query. It gives you a great GUI to work with to accomplish this. Depending on your version of excel it is either a free add-on or part of the shipped product(for new versions of office).
You do not need to know how to code to use this, you just need to understand the concepts.
While its not exactly the answer you are after i have successfully taught several people at my work place how to use this application that would have previously been reliant on me or someone else with VBA skills.
Sub copydocument()
Dim wb As Workbook
Dim wb1 As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo resetsettings
Set wb = ThisWorkbook
MyPath = "c:\Users\foo\" 'Path of folder with \ at the end
MyExtension = "*.xlsx"
Myfile = Dir(MyPath & MyExtension)
While Myfile <> vbNullString
Set wb1 = Workbooks.Open(MyPath & Myfile)
lr = wb.Sheets(1).Range("A1:A" & Rows.Count).End(xlUp).Row
lr1 = wb1.Sheets(1).Range("A1:A" & Rows.Count).End(xlUp).Row
wb1.Sheets(1).Range("A1:CV" & lr1).Copy Destination:=wb.Sheets(1).Range("A" & (lr + 1))
wb1.close
Myfile = Dir
Wend
resetsettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This macro will go through all the files in the folder and copy the sheet1 range and paste it in the active workbook sheet1. if you have headers and dont want them to repeat you can copy the header to the sheet1 of activeworkbook then copy range from (A2:CV &lr1).

Copying data from many workbooks to a summary workbook with Excel-VBA. Run time errors

I have files in a folder and I want to copy data from these files and paste them into another Master workbook sheet.
I keep getting a runtime error ‘1004’: Sorry we couldn’t find C:\Users\jjordan\Desktop\Test Dir\MASTER`, It is possible it was moved, renamed or deleted.
The error is highlighted on this line of code: Workbooks.Open SumPath & SumName
I have seen other questions similar to this on the web, I have tried making various changes. But still without success. Please advise.
Dir for source files: C:\Users\ jjordan \Desktop\Test Dir\GA Test\
Dir for Master file: C:\Users\ jjordan \Desktop\Test Dir\MASTER\
Source filenames differ, but all end in "*.xlsx."
Master filename: " MASTER – Data List - 2016.xlsm " ‘macro file
Source worksheet name = "Supplier_Comments"
Master worksheet name = "Sheet5"
Option Explicit
Sub GetDataFromMaster()
Dim MyPath As String
Dim SumPath As String
Dim MyName As String
Dim SumName As String
Dim MyTemplate As String
Dim SumTemplate As String
Dim myWS As Worksheet
Dim sumWS As Worksheet
'Define folders and filenames
MyPath = "C:\Users\jjordan\Desktop\Test Dir\GA Test\"
SumPath = "C:\Users\jjordan\Desktop\Test Dir\MASTER\"
MyTemplate = "*.xlsx" 'Set the template.
SumTemplate = "MASTER – Data List - 2016.xlsm"
'Open the template file and get the Worksheet to put the data into
SumName = Dir(SumPath & SumTemplate)
Workbooks.Open SumPath & SumName
Set sumWS = ActiveWorkbook.Worksheets("Sheet5")
'Open each source file, copying the data from each into the template file
MyName = Dir(MyPath & MyTemplate) 'Retrieve the first file
Do While MyName <> ""
'Open the source file and get the worksheet with the data we want.
Workbooks.Open MyPath & MyName
Set myWS = ActiveWorkbook.Worksheets("Suppliers_Comment")
'Copy the data from the source and paste at the end of sheet 5
myWS.Range("A2:N100").Copy
sumWS.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
'Close the current sourcefile and get the next
Workbooks(MyName).Close SaveChanges:=False 'close
MyName = Dir 'Get next file
Loop
'Now all sourcefiles are copied into the Template file. Close and save it
Workbooks(SumName).Close SaveChanges:=True
End Sub
Here is a template for what you'd like done. NOTE that forward slashes can cause run time error b/c vba handles them in an annoying way.
Sub DougsLoop()
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sheet As Worksheet
Application.ScreenUpdating = False 'these three statements help performance by disabling the self titled in each, remeber to re-enable at end of code
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
StartTime = Timer 'Starts timer to see how long code takes to execute. I like having this in macors that loop through files
path = "C:\Users\jjordan\Desktop\Test Dir\GA Test" & "\" 'pay attention to this line of code********
Filename = Dir(path & "*.xl??")
Set wsO = ThisWorkbook.Sheets("Sheet5")
Do While Len(Filename) > 0 'this tells the code to stop when there are no more files in the destination folder
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
For Each sheet In ActiveWorkbook.Worksheets
Set rRng = sheet.Range("a2:n100")
For Each rCell In rRng.Cells
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell
Next rCell
Next
wbk.Close False
Filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
alter to this to your needs and you'll find it works perfectly :)
EDIT: Also in your code you make use of COPY & PASTE a lot. Try avoid doing this in the future. Try doing something:
ThisWorkbook.Sheets("Sheet1").Range("a1").Value = OtherWork.Sheets("Sheet1").Range("a1").Value
This is more efficient and wont bog down your code as much.
here is some offset logic
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value =
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 1).Value =
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 2).Value =
notice the Offset(x,y) value? Essentially x is down and y is right. this is of course referencing the original position. So to get a value to go in the same row but three columns over you would use "Offset(0,3)" etc etc
Ill let you alter your code to do this. :)
I guess actually trying to piece it together was a struggle? Here this version assumes the macro is in the master workbook(and that youre running it form the master). If you want to change go ahead, but this is as far as I go. At some point, you'll have to experiment on your own.

MS Excel : update multiple Workbooks using a macro in a master spreadsheet

I have 30 + workbooks on SharePoint that are all copies of each other except for the filename and the folder they are in. We use these to record progress on projects as we can't put an access DB on our sharepoint (don't ask!)
I need to update the data validation on all of the spread sheets and based on history may well have other changes that need making in all spread sheets again in the future.
I've got a macro that will change the validation in the spreadsheet its in.
In a "master" spreadsheet I can create the paths to the other spreadsheets and get them opened.
But when I try to run the code (in the master) against each spreadsheet using the macro copied from the single sheet I get an error:
runtime error 9 subscript out of range
on the line
Set myDestinationWorkSheet = Workbooks(myFile).Sheets("Data")
I've checked and the "data" sheet is definitely there. I've even copy and pasted the sheet name from the worksheet just in case. I'm confident that the filename is correct as the line before it opens the file. I've tried referencing the sharepoint files directly with http:// in the constructed filename and via a mapped drive (in case it was a "path too long" type error).
Here's the code (mostly a combination of stuff from other Stackoverflow answers!)
Sub Macro1()
'
' Macro1 Macro
'
Dim namedRange As Range
Set namedRange = Range("Schools")
Dim i As Long
Dim rng As Range
Dim mySchool As String
Dim myFile As String
Dim myDestinationWorkSheet As Worksheet
' step through list of schools
For i = 5 To Range("D" & Rows.Count).End(xlUp).Row
' build file name
mySchool = Range("D" & i).Value
Set rng = Range("e" & i)
'record filename in ppm master for bug tracking
myFile = Range("b5").Value & mySchool & Range("b6").Value & Range("b7").Value & mySchool & Range("b8").Value
'get filename
rng.Value = myFile
' open file
Workbooks.Open (myFile)
Set myDestinationWorkSheet = Workbooks(myFile).Sheets("Data")
myDestinationWorkSheet.Range("C2:J200").Select
' do stuff to file
With Selection.Validation
.Delete
.Add Type:=xlValidateDate, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$L$13", Formula2:="=$L$15"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Date out of range"
.InputMessage = ""
.ErrorMessage = _
"Please enter a date in between the values shown in Cell L13 and cell L15"
.ShowInput = True
.ShowError = True
End With
'mark as done
myDestinationWorkSheet.Range("L30").Value = "date validation updated 2/7/2014 CJ)"
'save and close file
Workbooks(myFile).Save
Workbooks(myFile).Close
'move to next in the list
Next i
'
Range("D5:D27").Select
End Sub
Any help appreciated.
I think the problem is probably coming from your MyDestinationWorksheet variable. It's set as a Worksheet and worksheets do not need to have the workbook name.
I'd try replacing Set myDestinationWorkSheet = Workbooks(myFile).Sheets("Data") with Set myDestinationWorkSheet = ActiveWorkbook.Sheets("Data") being as you've already opened the workbook you wish to set the myDestinationWorksheet variable to.
While your worksheet does not need a workbook name, it can be good practice to specify which workbook you're intending to work in. The problem is that your myFile is a file path and workbook name that works for Workbooks.Open (myFile) because those are necessary for the .Open method, but Workbooks(myFile) should have only the workbook name. You need to trim off the file path.