Background
First of all I realise all of this is a perfect task for a database but I don't currently have that option available and I think it's a good learning experience to continue doing this in excel.
I have multiple workbooks each containing a list of identifying numbers, through the code below I enter the name of the workbook I require and the list is imported to main my workbook containing multiple columns of data. I then ran my Match and Export sub to break up the main data set into different sheets.
Question
Is there a way to use a for loop for each of the files in the containing folder so that I don't have to identify each workbook in turn?
Sub Export_Specified_Contractor()
Dim listwb As Workbook, mainwb As Workbook
Dim fname As String
Dim sht As Worksheet, oput As Worksheet
Dim LRow As Long, oLRow As Long
Dim cprng As Range, orng As Range
'--> Get the name of the contractor list to be exported
fname = Application.InputBox("Enter Contractor Name", "Name?")
Set mainwb = ThisWorkbook
With Application
'--> Set contractor list file
Set listwb = .Workbooks.Open _
("C:\Documents and Settings\alistairw\My Documents\Disallowed Items\Contractor Lists\" & fname)
End With
Set sht = listwb.Sheets("Sheet1")
'--> Copy contractor list
With sht
LRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:A" & LRow).Copy
End With
mainwb.Activate
'--> Create contractor list sheet in main workbook and paste values
With mainwb
On Error Resume Next
Sheets("Sheet2").Delete
Sheets.Add.Name = "Sheet2"
Set oput = Sheets("Sheet2")
With oput
.Range("A1").PasteSpecial
End With
End With
Call Match_and_Export
'--> Delete the list workbook and list sheet
Application.DisplayAlerts = False
listwb.Close
oput.Delete
Application.DisplayAlerts = True
End Sub
looping through a folder:
MyPath = "C:\Documents and Settings\alistairw\My Documents\Disallowed Items\Contractor Lists\"
strFilename = Dir(MyPath & "\*.xlsx", vbNormal) 'change to xls if needed
If Len(strFilename) = 0 Then Exit Sub ' exit if no files in folder
Do Until strFilename = ""
'Your code here
strFilename = Dir()
Loop
Related
I have multiple workbooks in a single folder. All the workbooks share the same format and I wish to copy from the same range on the first worksheet in all workbooks and add this to a single worksheet of a newly created workbook.
The code so far:
Sub OpenAllCompletedFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
CopyDataToTotalsWorkbook currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub AddWorkbook()
Dim TotalsWorkbook As Workbook
Set TotalsWorkbook = Workbooks.Add
outWorkbook.Sheets("Sheet1").Name = "Totals"
outWorkbook.SaveAs FileName:="pathway..."
End Sub
Sub CopyDataToTotalsWorkbook(argWB As Workbook)
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Dim TotalsBook As Workbook
Set TotalsBook = Workbooks.Open("pathway...")
Set wsDest = TotalsBook.Worksheets("Totals")
Application.DisplayAlerts = False
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
wsDest.Range("A" & lDestLastRow).PasteSpecial
Application.DisplayAlerts = True
TotalsBook.Save
End Sub
This works - to a point. It does copy the correct ranges across and place the results one below another on the "Totals" worksheet of the "Totals" workbook, but it raises a 'Subscript out of range' error on:
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
after data from the last workbook has been pasted.
How can I tidy this code so that it works without error?
I imagine there is scope to improve the code too.
I'd maybe do something like this.
Note you can just open the summary workbook once before looping over the files.
Sub SummarizeFiles()
'Use `Const` for fixed values
Const FPATH As String = "C:\Test\" 'for example
Const TOT_WB As String = "Totals.xlsx"
Const TOT_WS As String = "Totals"
Dim FileName As String, wbTot As Workbook, wsDest As Worksheet
'does the "totals" workbook exist?
'if not then create it, else open it
If Dir(FPATH & TOT_WB) = "" Then
Set wbTot = Workbooks.Add
wbTot.Sheets(1).Name = TOT_WS
wbTot.SaveAs FPATH & TOT_WB
Else
Set wbTot = Workbooks.Open(FPATH & TOT_WB)
End If
Set wsDest = wbTot.Worksheets(TOT_WS)
FileName = Dir(FPATH & "*.xlsx")
Do While Len(FileName) > 0
If FileName <> TOT_WB Then 'don't try to re-open the totals wb
With Workbooks.Open(FPATH & FileName)
.Worksheets("Weekly Totals").Range("A2:M6").Copy _
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.Close False 'no changes
End With
End If
wbTot.Save
FileName = Dir 'next file
Loop
End Sub
I try to merge data from different excel workbooks with the same worksheet names in them, into 1 separate excel workbook. My code merges all worksheets in those workbooks. For example: that 1 separate excel looks like that in the end: a,b,c,a(2),b(2),c(2),a(3),b(3),c(3)
I need to enter the criteria that it merges all worksheets with name "a" from different workbooks into a single worksheet "a" in the separate excel file.
here is my code:
Sub CombineWorkbooks()
Dim Path As String
Path = "C:\Users\Desktop\Products_test\"
Dim FileName As String
FileName = Dir(Path & "*.xlsm")
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open Path & FileName
For Each ws In ActiveWorkbook.Sheets
ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next ws
Workbooks(FileName).Close
FileName = Dir()
Loop
Worksheets(1).Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
This code will loop through all the workbooks in the specified folder.
It will copy each worksheet from the workbooks to the workbook the code is in, i.e. ThisWorkbook.
It checks to see if a worksheet with same name as that being copied exists in the destination workbook.
If a worksheet with the same name is found then the data from the source worksheet is copied below the existing data.
If a worksheet with the same name is not found the entire worksheet is copied to the destination workbook.
Option Explicit
Sub CombineWorkbooks()
Dim wbSrc As Workbook
Dim wsDst As Worksheet
Dim wsSrc As Worksheet
Dim rngSrc As Range
Dim Path As String
Dim FileName As String
Path = "C:\Users\vladimir\Desktop\Products_test\"
FileName = Dir(Path & "*.xlsm")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Set wbSrc = Workbooks.Open(Path & FileName)
For Each wsSrc In wbSrc.Sheets
Set wsDst = FindWS(wsSrc.Name, ThisWorkbook)
If wsDst Is Nothing Then
wsSrc.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Else
With wsSrc.Range("A1").CurrentRegion
Set rngSrc = .Offset(1).Resize(.Rows.Count - 1)
End With
rngSrc.Copy wsDst.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next wsSrc
wbSrc.Close
FileName = Dir()
Loop
Worksheets(1).Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Function FindWS(strWSName As String, wb As Workbook) As Worksheet
Dim ws As Worksheet
For Each ws In wb.Sheets
If ws.Name = strWSName Then
Exit For
End If
Next ws
If Not ws Is Nothing Then
Set FindWS = ws
End If
End Function
In your comment you mention two possible solutions. Here's the simpler solution, which is having an end result of a, a(2), a(3)
To do that, replace the three lines of the For...Next loop with this:
For Each ws In ActiveWorkbook.Sheets
If ws.Name = "a" Then
ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next ws
That will only copy across the worksheets that are called a, so all of the b and c sheets will be ignored.
The other solution is also possible. When I have a bit more time available I'll write that up (or anyone else can).
i'm a beginner in VBA and i need to do the following. Starting from a workbook i should create another one without formulas and macro code.
I found some solutions and based on that i modeled my own code:
Sub SaveValuesOnly()
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim sFileName As String, sPath As String
sPath = "C:\Users\"
sFileName = "OVERALL RECAP"
Set wsCopy = ThisWorkbook.Worksheets("INCIDENTS")
Set wb = Workbooks.Add
Set wsPaste = wb.Sheets(1)
wsCopy.Cells.copy
wsPaste.Cells.PasteSpecial xlPasteValues
wsPaste.Cells.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
wsPaste.Name = "Expenses" 'Change if needed
wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
End Sub
I need to copy more than one sheet and tried to use the official documentation like:
Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy
With ActiveWorkbook
.SaveAs Filename:=Environ("TEMP") & "\New3.xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
But i didn't manage to implement this into the code above, any suggestion? Thanks.
Copy Worksheets to New Workbook
The Flow
Basically, the procedure will:
create a copy of ThisWorkbook (the workbook containing this code) in the destination folder,
open the copy and continue to work with it,
copy values to (remove formulas from) the specified worksheets,
delete the not specified sheets,
rename the specified worksheets,
save the copy to a new workbook in .xlsx format,
delete the copy.
Remarks
If a workbook with the same name (e.g. OVERALL RECAP) is already open, it will crash Excel.
Be careful when determining the worksheet names, because if you try to rename a worksheet using an already existing name, an error will occur.
The Code
Option Explicit
Sub copyWorksheets()
Const dPath As String = "C:\Users"
Const dFileName As String = "OVERALL RECAP"
Const CopyList As String = "INCIDENTS,Sheet2,Sheet3"
Const PasteList As String = "Expenses,Sheet2,Sheet4"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim CopyNames() As String: CopyNames = Split(CopyList, ",")
Dim PasteNames() As String: PasteNames = Split(PasteList, ",")
Dim nUpper As Long: nUpper = UBound(CopyNames)
Dim tFilePath As String: tFilePath = dPath & "\" & "t_" & wb.Name
Application.ScreenUpdating = False
' Save a copy.
wb.SaveCopyAs tFilePath
' Work with the copy.
With Workbooks.Open(tFilePath)
' Copy values (remove formulas).
Dim n As Long
For n = 0 To nUpper
With .Worksheets(CopyNames(n)).UsedRange
.Value = .Value
End With
Next n
' Delete other sheets.
Dim dCount As Long: dCount = .Sheets.Count - nUpper - 1
If dCount > 0 Then
Dim DeleteNames() As String: ReDim DeleteNames(1 To dCount)
Dim sh As Object ' There maybe e.g. charts.
n = 0
For Each sh In .Sheets
If IsError(Application.Match(sh.Name, CopyNames, 0)) Then
n = n + 1
DeleteNames(n) = sh.Name
End If
Next sh
Application.DisplayAlerts = False
.Sheets(DeleteNames).Delete
Application.DisplayAlerts = True
End If
' Rename worksheets.
For n = 0 To nUpper
If CopyNames(n) <> PasteNames(n) Then
.Worksheets(CopyNames(n)).Name = PasteNames(n)
End If
Next n
' Save workbook.
.Worksheets(1).Activate
Application.DisplayAlerts = False
.SaveAs _
Filename:=dPath & "\" & dFileName, _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'.Close SaveChanges:=False ' Close the new workbook.
End With
' Delete the copy.
Kill tFilePath
Application.ScreenUpdating = True
MsgBox "Workbook created.", vbInformation, "Success"
'wb.Close SaveChanges:=False ' Close ThisWorkbook.
End Sub
The code below takes the opposite approach to the earlier one. It copies the entire workbook to a new name and then modifies it. You can list the sheets you want to keep. Formulas in them will be converted to their values. Sheets not listed will be deleted.
Sub SaveValuesOnly()
' 154
' list the sheets you want to keep by their tab names
Const SheetsToKeep As String = "Sheet1,Sheet3"
Dim sFileName As String
Dim sPath As String
Dim Wb As Workbook ' the new workbook
Dim Ws As Worksheet ' looping object: worksheet
Dim Keep() As String ' array of SheetsToKeep
Dim i As Long ' loop counter: Keep index
sPath = Environ("UserProfile") & "\Desktop\"
sFileName = "OVERALL RECAP"
Keep = Split(SheetsToKeep, ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' create a copy of the ActiveWorkbook under a new name
ActiveWorkbook.SaveCopyAs sPath & sFileName & ".xlsm"
Set Wb = Workbooks.Open(sPath & sFileName & ".xlsm")
For Each Ws In Wb.Worksheets
' check if the sheet is to be kept
For i = UBound(Keep) To 0 Step -1
If StrComp(Ws.Name, Trim(Keep(i)), vbTextCompare) = 0 _
Then Exit For
Next i
If i = True Then ' True = -1
Ws.Delete
Else
' keep the sheet
With Ws.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats
' you can repeat PasteSpecial here to copy more detail
End With
End If
Next Ws
' change the file format to xlsx (deleting copy of this code in it)
Wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
Kill sPath & sFileName & ".xlsm"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
There are a few points you need to be aware of. One, the ActiveWorkbook will be copied. That is presumed to the ThisWorkbook (the one containing the code) but it could be any other. Two, any workbook by the targeted name already existing at the location specified by sPath will be over-written without warning. Three, alerts are turned off while the code runs. If it happens to crash they will remain turned off until you restart Excel or enter Application.DisplayAlerts = True [Enter] in the Immediate window.
Last, but not least, sheets are processed in sequence of their index numbers (left to right). If your formulas in the kept sheets refer to data in sheets that get deleted the sequence is important. You may have to run two loops instead of the one my code has. Use one loop to replace formulas and another just to delete.
My aim is to merge all workbooks having multiple sheets from any specified folder to one workbook of multiple sheets. (I have attached code below)
The problem is I don’t want external links to be maintained, I tried to break these links using Macro, it’s also working. (just using breaklink command, attached below)
But what I exactly want is, After merging all workbooks in one workbook, instead of external links I need links b/w these merged sheets, so is there any strategy that I can use?
Code for merge all workbooks into one workbook
Sub merge()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = "C:\Users\Samiya jabbar\Desktop\test\"
Filename = Dir(FolderPath)
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Break link
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
In order to move all formula references correctly:
Open all files that are involved before you start moving.
Move your sheets (don't copy them).
After all movements are done: Close the files you don't need anymore (don't save changes if you want to keep the original files as before moving sheets).
Save your merged workbook.
Here is a proof of concept:
First we create 3 files with 2 workbooks each
Public Sub CreateTestWorkbooks()
Const Path As String = "C:\Temp\MoveTest\"
Const nWb As Long = 3 'amount of workbooks to create
Const nWs As Long = 2 'amount of worksheets in each workbook
Dim NewWb() As Workbook
ReDim NewWb(1 To nWb) As Workbook
Dim iWs As Long
Application.ScreenUpdating = False
'create workbooks
Dim iWb As Long
For iWb = 1 To nWb
Set NewWb(iWb) = Application.Workbooks.Add
For iWs = 1 To nWs - 1
NewWb(iWb).Worksheets.Add After:=NewWb(iWb).Sheets(NewWb(iWb).Sheets.Count)
Next iWs
NewWb(iWb).SaveAs Filename:=Path & "File" & iWb & ".xlsx"
Next iWb
'write formulas
Dim iFormula As Long
For iWb = 1 To nWb
For iWs = 1 To nWs
NewWb(iWb).Worksheets(iWs).Range("A1").Value = "File" & iWb & ".xlsx " & "Sheet" & iWs
For iFormula = 1 To nWb
NewWb(iWb).Worksheets(iWs).Cells(iFormula, "B").Formula = "=[File" & iFormula & ".xlsx]Sheet" & iWs & "!$A$1"
Next iFormula
Next iWs
Next iWb
'save and close workbooks
For iWb = 1 To nWb
NewWb(iWb).Close SaveChanges:=True
Next iWb
Application.ScreenUpdating = True
MsgBox "All " & nWb & " files were created.", vbInformation
End Sub
Then we consolidate them
Public Sub ConsolidateWorkbooks()
Const Path As String = "C:\Temp\MoveTest\"
Dim OpenedWorkbooks As Collection
Set OpenedWorkbooks = New Collection
Application.ScreenUpdating = False
'loop through files and open them all
Dim File As String
File = Dir(Path & "*.xlsx")
Do While File <> vbNullString
OpenedWorkbooks.Add Application.Workbooks.Open(Filename:=Path & File, UpdateLinks:=True)
File = Dir()
Loop
'create a new workbook to consolidate all worksheets
Dim ConsolidateWb As Workbook
Set ConsolidateWb = Application.Workbooks.Add
'consolidate
Dim wb As Workbook
For Each wb In OpenedWorkbooks
Dim sh As Variant
For Each sh In wb.Sheets
sh.Move After:=ConsolidateWb.Sheets(ConsolidateWb.Sheets.Count)
'this changes the constant in A1 of each sheet to make it
'visible that formulas are now pointing to the new file (no formula changes are made here)
With ConsolidateWb.Sheets(ConsolidateWb.Sheets.Count)
.Range("A1").Value = "Consolidated.xlsx " & .Name
End With
Next sh
Next wb
Application.ScreenUpdating = True
ConsolidateWb.SaveAs Filename:=Path & "Consolidated.xlsx"
End Sub
I want to open a workbook that contains only one sheet,
copy data up to column AC until last available row in column A,
paste the data into first empty row in column A in workbook "Mergedsheet.xlsx".
I want to loop over all workbooks present in a specific folder, but get lots of errors.
Sub MergeNew()
Dim WorkBk As Workbook
Dim MergedSheet As Worksheet
Dim SourceData As Range
Dim DestinationData As Range
Dim lastRow As Long
Dim NextRow As Range
Dim FolderPath As String
Dim FileNames As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FolderPath = "E:\Jan to March 2019\Bharuch 31\"
FileNames = Dir(FolderPath & "*.xls*")
Do While FileNames <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileNames)
Range("A1:AC1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Open Filename:="E:\Jan to March 2019\Bharuch 31\MergedSheet.xlsx"
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastRow).Select
ActiveSheet.Paste
'ActiveWindow.Close SaveChanges:=True
'ActiveWindow.Close SaveChanges:=False
Application.CutCopyMode = False
FileNames = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You are looping through a folder and copy-pasting each workbook's first sheet's data to workbook A. However, workbook A is also in that folder. So you should take care to skip it (when looping).
(Alternatively, you could provide a different argument to the DIR function (e.g. some wildcard criteria that excludes workbook A if possible), so that you don't have to constantly check inside the loop.)
Untested.
Option Explicit
Private Sub MergeNew()
'Application.ScreenUpdating = False 'Uncomment this when you know code is working.
'Application.DisplayAlerts = False 'Uncomment this when you know code is working.
Dim folderPath As String
folderPath = GetFolderPath(titleToShow:="Select the folder containing the files to loop through.")
Dim Filename As String
Filename = Dir$(folderPath & "*.xls*")
If Len(Filename) = 0 Then
MsgBox "Could not find a relevant file in '" & folderPath & "'. Code will stop running now."
Exit Sub ' No point in carrying on in such a case.
End If
Dim destinationFolderPath As String
destinationFolderPath = GetFolderPath(titleToShow:="Select the folder to save the 'MergedSheet.xlsx' file to.")
Dim destinationWorkbook As Workbook
Set destinationWorkbook = Application.Workbooks.Add
' This line may throw an error
destinationWorkbook.SaveAs Filename:=destinationFolderPath & "MergedSheet.xlsx", FileFormat:=xlOpenXMLWorkbook
Dim destinationSheet As Worksheet
Set destinationSheet = destinationWorkbook.Worksheets(1) ' I assume there's only 1 sheet in there, but change as necessary.
Do Until Len(Filename) = 0
Dim fullFilePathToOpen As String
fullFilePathToOpen = folderPath & Filename
If fullFilePathToOpen <> destinationWorkbook.FullName Then ' Probably could have just compared filename since directory is the same, but this is more explicit
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Application.Workbooks.Open(Filename:=fullFilePathToOpen, ReadOnly:=True) ' If you don't make changes to the workbook you open, better to open as read-only
Dim sourceSheet As Worksheet
Set sourceSheet = sourceWorkbook.Worksheets(1) ' You say there's only one worksheet in there, so referring by index should be okay (for now)
Dim lastSourceRow As Long
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Assume last row can be determined from column A alone
Dim lastDestinationRow As Long
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row + 1
If destinationSheet.Rows.Count < (lastDestinationRow + lastSourceRow) Then
MsgBox "Ran out of rows (in sheet '" & sourceSheet.Name & "' of workbook '" & destinationWorkbook.Name & "')"
Exit Sub
End If
sourceSheet.Range("A1", sourceSheet.Cells(lastSourceRow, "AC")).Copy Destination:=destinationSheet.Cells(lastDestinationRow, "A")
sourceWorkbook.Close False
End If
Filename = Dir$()
Loop
'Application.ScreenUpdating = True 'Uncomment this when you know code is working.
'Application.DisplayAlerts = True 'Uncomment this when you know code is working.
End Sub
Private Function GetFolderPath(Optional ByVal titleToShow As String = vbNullString) As String
With Application.FileDialog(msoFileDialogFolderPicker)
If Len(titleToShow) > 0 Then .Title = titleToShow
.AllowMultiSelect = False ' Only one is allowed.
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Folder selection appears to have cancelled. Code will stop running now"
End
End If
GetFolderPath = .SelectedItems(1) & "\"
End With
End Function