I have written a macro that can successfully loop through a folder, copy and paste the information into a new workbook, and insert three formulas. I'm having problems, though, with the index functions in some macros I call not displaying correctly.
Sub LoopAllExcelFilesInFolder()
Application.ScreenUpdating = False
Dim MyFolder As String
Dim MyFile As String
MyFolder = "C:\Users\myname\Desktop\Test Files"
MyFile = Dir(MyFolder & "\*.xlsx")
'This is where my loop code starts
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=0
Sheets("Report").Activate
Sheets("Report").Cells.Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Selection.Copy
ActiveWorkbook.Close True
Windows("Database Loop Test.xlsm").Activate
Sheets("PORT").Activate
Range("A1").Select
ActiveSheet.Paste
'It is successfully pasted to the desired workbook
'Here I call macros that insert sum, mid, and index functions. Sum and mid work but index doesn't
Call icvba
Call iovba
Call idvba
MyFile = Dir
Loop
End Sub
The weird thing is, when I check the index functions after I run the macro, they are all correct. Instead of showing the correct numbers, it shows up as #N/A. Here is the code for the macros I am calling. The code is the same for all three; only the worksheet is being changed.
Sub icvba()
Worksheets("COMMIT").Activate
Dim source As Worksheet
Dim detntn As Worksheet
Dim EmptyColumn As Long
Dim LastRow As Long
Set source = Sheets("vlookup")
Set detntn = Sheets("COMMIT")
LastColumn = detntn.Cells(1, detntn.Columns.Count).End(xlToLeft).Column
LastRow = Worksheets("COMMIT").Range("A:A").Rows.Count
'This if statement inputs the troublesome index function
If detntn.Range("A2") <> "" Then
EmptyColumn = LastColumn + 1
detntn.Cells(3, EmptyColumn).Formula = "=INDEX(PORT!$S$5:$S$4000,MATCH(COMMIT!$G3,PORT!$G$5:$G$4000,0))"
LastRow = ActiveSheet.UsedRange.Rows.Count
detntn.Cells(3, EmptyColumn).AutoFill destination:=detntn.Range(detntn.Cells(3, EmptyColumn), detntn.Cells(LastRow, EmptyColumn))
End If
'This if statement inputs the mid function
If detntn.Range("A2") <> "" Then
detntn.Cells(2, EmptyColumn).Formula = "=MID(PORT!$A$2,7,50)"
End If
'This if statement inputs a sum function
If detntn.Range("A2") <> "" Then
Worksheets("vlookup").Activate
ActiveSheet.Range("A1").Select
Selection.Copy
Worksheets("COMMIT").Activate
detntn.Cells(1, EmptyColumn).Select
Selection.PasteSpecial Paste:=xlAll
End If
Columns(EmptyColumn).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub
Additionally, when I call the icvba, iocba, idvba macros individually, they work perfectly. It is only when I call them inside of my loop function that they stop working.
This is the first loop I have written with VBA, so I might be missing something simple. I just can't figure out where I'm going wrong. Any help would be much appreciated!
Sounds like the formulas just haven't calculated - Try putting this just before copying doing the pastespecial at the end:
Not_Calculated:
Application.Wait(Now + TimeValue("0:00:04")) if not
Application.CalculationState = xlDone then goto Not_Calculated
That basically pauses the Macro from going any further for 4 seconds to allow the calculation complete and if it still hasn't wait another 4 seconds
Related
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
...
I'm trying to write a VBA code to copy "Non-Blank" cells from one file to another. This code selects the last Non Blank row, but for the column it's copying A4 to AU. I'd like to copy columns A4 to LastcolumnNotblank and also last row. So basically copy A4 to (LastColumn)(LastRow)Not Blank
Would be really grateful if someone can help by editing the below code. Many thanks.
Sub Export_Template()
'' TPD
File_name = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If File_name <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRow
If Left(ActiveSheet.Range("A" & i).Value, 1) <> "" Then lastactiverow = i
Next i
'MsgBox (lastactiverow)
ActiveSheet.Range("A4:AU" & lastactiverow).Select
Selection.Copy
Set NewBook = Workbooks.Add
ActiveSheet.Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs Filename:=File_name, FileFormat:=51
ActiveWorkbook.Close (False)
End If
End Sub
The code below will preserve your ActiveSheet range and use SaveAs to save to a new workbook with your specific name, without all the extra crap. It deletes all the sheets except for the ActivSheet, and deletes the first three rows, then using SaveAs to save to ThisWorkbook.Path. Your macro enabled workbook will not be changed.
I actually don't like to use ActiveSheet due to the obvious problems, but since you were using it i kept it. I would suggest you use the name of the worksheet.
Sub SaveActiveSheetRangeAsNewWorkbook()
Dim ws As Worksheet
Application.DisplayAlerts = False
With ThisWorkbook
For Each ws In Application.ThisWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.Delete
End If
Next
.Sheets(1).Range("A1:A3").EntireRow.Delete
.SaveAs Filename:="Engineering TPD", FileFormat:=xlOpenXMLWorkbook
End With
Application.DisplayAlerts = True
End Sub
I'm assuming that Col A is a good indicator of where to find your last used row
Also assuming that Row 1 is a good indicator of where to find your last used column
You need to change Sheet1 on 3rd line of code to the name of your sheet that has the data to be copied
You need to declare variables (Use Option Explicit)
Avoid .Select and .Selection at all costs (none are found in below solution)
You did not re-enable ScreenUpdating and DisplayAlerts
This is tested and works A-OK
Option Explicit
Sub Export_Template()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim NewBook As Workbook
Dim LRow As Long, LCol As Long
Dim FileName
FileName = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If FileName <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set NewBook = Workbooks.Add
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
LCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
ws.Range(ws.Cells(4, 1), ws.Cells(LRow, LCol)).Copy
NewBook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
NewBook.SaveAs FileName:=FileName, FileFormat:=51
NewBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub
I have a code that loop through excel files in a folder and copy the value and paste them to a new workbook.
The problem occur when I have files that only have a single value in the cell. It return an error stating
copy area and paste area aren't the same size
Below is my code:
Sub MergeDataFromWorkbooks()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim wbk1 As Workbook
Set wbk1 = ThisWorkbook
Dim Filename As String
Dim Path As String
Path = "C:\Users\Desktop\merge all to one\" 'CHANGE PATH ACCORDING TO FOLDER DIRECTORY LEAVING \ AT THE END
Filename = Dir(Path & "*.xlsx")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)
wbk.Activate
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Book1.xlsm").Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(1).Select
Cells(lr + 1, 1).Select
ActiveSheet.Paste
wbk.Close True
Filename = Dir
Loop
MsgBox "All the files are copied and pasted in Book1."
End Sub
First of all some thoughts to improve your coding style
You should avoid using Selection, Select and Activate because this is a bad practice and slows down your code a lot. You can do all actions without using them. In most cases you should never use them (there are a very little number of special cases).
Don't use eg. Range or Cells without specifying a worksheet. Otherwise Excel tries to guess which worksheet you mean and it will probably fail doing this. Guessing is not knowing, therefore always tell Excel which worksheet you mean like Worksheets(1).Range or Worksheets("SheetName").Range.
Use descriptive variable names. Names like wbk and wbk1 are not very descriptive and later you don't know what wbk1 was and mess things up. Instead use something like wbDestination and wbSource everybody knows what that means now.
Also it might be a good practice to declare the variables close to their first use, especially when code gets a bit longer.
Always use Worksheets instead of Sheets if possible. Sheets also contains charts not only workbooks but in most cases you just want the Worksheets. You say it doesn't matter? Well it does. Sheets(1).Range will throw an error if the first sheet is a chart. We can avoid that.
Now lets start tidy up …
Instead of activate, select 3 times and copy
wbk.Activate
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
We can just copy without any ativate or select which is a lot faster and has the same effect:
With wbSource.Worksheets(1).Range("A2")
'copy without select
.Resize(.End(xlDown).Row - .Row + 1, .End(xlToRight).Column - .Column + 1).Copy
End With
When we close the source workbook
wbSource.Close SaveChanges:=False
we don't need to save the changes because we didn't change anything. This is more secure and a lot faster.
So we end up with
Option Explicit
Sub MergeDataFromWorkbooks()
Dim wbDestination As Workbook
Set wbDestination = ThisWorkbook
Dim Path As String
Path = "C:\Temp\" 'make sure it ends with \
Dim Filename As String
Filename = Dir(Path & "*.xlsx")
Do While Len(Filename) > 0 'while file exists
Dim wbSource As Workbook
Set wbSource = Workbooks.Open(Path & Filename)
With wbSource.Worksheets(1).Range("A2")
'copy without select
.Resize(.End(xlDown).Row - .Row + 1, .End(xlToRight).Column - .Column + 1).Copy
End With
Dim lRow As Double
lRow = wbDestination.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'find next empty row
wbDestination.Worksheets(1).Cells(lRow + 1, 1).PasteSpecial Paste:=xlPasteAll 'paste all
wbSource.Close SaveChanges:=False 'we don't need to save changes we didn't change anything just copied
Filename = Dir 'next file
Loop
MsgBox "All the files are copied and pasted in Book1."
End Sub
Alternative way to determine the last used cell (column and row) in the source file
This avoids errors when row 2 is the last used row.
With wbSource.Worksheets(1).Range("A2")
.Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row - .Row + 1, .Parent.Cells(.Row, .Parent.Columns.Count).End(xlToLeft).Column - .Column + 1).Copy
End With
Explanation:
.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row
finds the last used row in column A by starting from the very last cell in Excel and going up (like pressing ctrl + up).
I don't see why your code is thrown a Copy Area and Paste area aren't the same size error. Unless there are merged cells.
Select and Active are generally used to show the user something. You can and should not use them unless absolutely necessary. I recommend watching: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)
Dim Source As Range
Application.DisplayAlerts = False
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
With Workbooks.Open(Path & Filename)
Set Source = .Range(.Range("A" & .Rows.Count).End(xlUp), .Cells(1,
.Columns.Count).End(xlToLeft))
End With
Source.Copy Workbooks("Book1.xlsm").Range("A" & .Rows.Count).End(xlUp)
.Close False
Filename = Dir
Loop
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).
I have the following code in a macro in my personal book, and it works perfectly.
I'm trying to copy it into the actual wb it's running from so I can send it around for others to use, and it's breaking at the commented line "XXXXXX". The selected wb is being opened fine, but none of the subsequent editing occurs to that book. All of the following code (deletion of columns, etc) that should be happening to the opened workbook only happens to the wb running the macro, which is...sub-optimal.
I don't know why! Any thoughts welcomed.
Thank you
Sam
Sub PredictBoxValue()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim TitleName As String
Dim sas As String
Dim sos As String
Dim unusedRow As Long
Dim filename As String
'Optimize Macro Speed
Application.ScreenUpdating = False
'Application.EnableEvents = False
'Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
sos = ActiveWorkbook.Name
ActiveSheet.Range("B11", "AF11").Clear
Dim fNameAndPath As Variant
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS),
*.XLS", Title:="Select File To Be Opened")
If fNameAndPath = False Then Exit Sub
Set wb = Workbooks.Open(fNameAndPath)
sas = ActiveWorkbook.Name
'Delete extraneous columns and rows
'XXXXXXXXXXX
TitleName = Cells(5, 2).Value
Columns(8).Delete
Columns(12).Delete
Columns(12).Delete
Columns(3).Delete
Columns(2).Delete
Columns(1).Delete
Rows(3).Delete
Rows(2).Delete
Rows(1).Delete
Here:
Do Until Cells(2, 1).Value = "1"
Range("A1").End(xlDown).Select
'Do Until ActiveCell.Value = "1"
'ActiveCell.Offset(1).Select
'Loop
Do While ActiveCell.Value < 1
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Loop
ActiveCell.Offset(-1, 1).Select
Do While ActiveCell.Offset(0, -1).Value > 30
ActiveCell.EntireRow.Delete
GoTo Here
Loop
ActiveCell.Resize(, 7).Cut ActiveCell.Offset(1, 0).End(xlToRight).Offset(0,
1)
ActiveCell.EntireRow.Delete
Loop
Rows(1).EntireRow.Delete
Cells(1, 1) = TitleName
Range("A1", Range("A1").End(xlToRight)).Copy
Windows(sos).Activate
ActiveSheet.Cells(11, 2).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Windows(sas).Activate
'Save and Close Workbook
wb.Close SaveChanges:=False
Windows(sos).Activate
ActiveSheet.Cells(5, 3).Select
'Message Box when tasks are completed
MsgBox ("Data uploaded for ") & Range("B11")
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I took a bit of a closer look at your code. I think you are saying that you want to run code from macros.xlsm (or something like that), and have it operate on mydata.xlsx (or some such). Therefore, in your macro, ThisWorkbook will refer to macros.xlsm (should you need to refer to that).
After you have done Set wb = Workbooks.Open(fNameAndPath) to open mydata.xlsx, only and always refer to wb and wb.Sheets("whatever") when you are talking about mydata.xlsx.
Don't use Columns, Rows, Sheets, or Cells without a sheet reference in front of them
Don't use ActiveWorkbook/ActiveWorksheet at all.
Instead of ActiveCell, use a named range, e.g., as in this answer to the question BruceWayne noted.
That should take care of it!
<soapbox>And, in general, please be careful of your indentation and use longer variable names — both will help you avoid bugs as you work on this code.</soapbox>