Combining macros in Excel - vba

I'm trying to combine/nest 3 different functions in Excel VBE: open, loop, and click. I have them written out separately, but am unsure of how to combine them. I've tried the "call macro" function but got a compile error returned to me.
The goal is to open a bunch of files within a certain folder and click on the URL in all of them (the URL will not always be the same, so I need a click function that targets any unknown URL within a sheet).
Open macro:
Sub openMyfile()
Dim Source As String
Dim StrFile As String
Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub
Loop macro:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
For Each file In MySource.Files
If InStr(file.Name, "test") > 0 Then
End If
Next file
End Sub
Click macro (this needs some work):
Private Sub CommandButton1_Click()
Call NewSub
End Sub

Sub ReadWorkbooksInCurrentFolder()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim MyPath As String
Dim strFilename As String
'Stop annoying popups while macro is running
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
Set wbDst = ThisWorkbook
srcSheetName = "Data"
dstSheetName = "Results"
'I want to loop through all .xlsx files in the folder
MyPath = ThisWorkbook.Path
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then
MsgBox "No workbooks found ending in .xlsx in current folder"
Exit Sub
End If
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
wbSrc.Close
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)
'Copy cell A1 contents in source workbook to destination workbook cell A1
wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")
End Sub
Please edit the subroutine CollectData() so that it suits your needs, i.e. performs the click / url open. (I am not familiar with opening urls from excel, but I loop through workbooks often)

This code will open all Excel files in the IC_New folder on the desktop.
It will then look at each sheet and follow any hyperlinks that are on the sheet.
Sub Open_ClickHyperlinks()
Dim sPath As String
Dim vFiles As Variant
Dim vFile As Variant
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim HLink As Hyperlink
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
"IC_New" & Application.PathSeparator
'Return all files that have an extension starting with xls.
vFiles = EnumerateFiles(sPath, "xls*")
'Loop through each file.
For Each vFile In vFiles
'Open the file
Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
With wrkBk
'Loop through each worksheet in the file.
For Each wrkSht In .Worksheets
'Loop through each hyperlink on the worksheet.
For Each HLink In wrkSht.Hyperlinks
HLink.Follow
Next HLink
Next wrkSht
.Close SaveChanges:=False
End With
Next vFile
End Sub
'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function

Related

Encountering a problem in my Do while loop

New to VBA and initially my problem was to copy text in CSV file into string and then ultimately to a master workbook. I used the below code which works perfectly:
Sub Compiler()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim MyPath As String
Dim strFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
MyPath = "W:\Test Folder\"
strFilename = Dir(MyPath, vbNormal)
Do While strFilename <> ""
Dim buffer As String
Open MyPath & strFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
'Application.CutCopyMode = False
strFilename = Dir()
Loop
End Sub
However, for some reason, it only copy pastes some of the files and not others (or maybe it overwrites it?, point is some of the files are not copied in). Not sure why this is the case? Is it because there are some blank cells in files? To rectify this, i replaced all blank cells with 0 - didn't work. Is it because of different copy paste area? Don't know how to rectify that if this is the case
So after long investigation, i found out an impractical approach where if you paste in files that you need to copy one by one, It does the trick but it is inefficient. So just for a temp solution, i did the following where vba code copies in a file from a temp folder to the source folder, does its job of copy pasting to the master work book and then deletes the file that was copied in. For some reason, the code stops at the first even though it's a Do while loop. Not sure what's the problem here and what is most efficient approach here?
Sub ISINCompiler()
'Declare Variables
Dim FSO
Dim MyPath As String
Dim strFilename As String
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Test Folder\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
Do While strFilename <> ""
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
ISINCompilerx2 '<-Copying and pasting in text
DeleteExample1 '<-Deleting the file after it has been copied in
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
strFilename = Dir()
Loop
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim someotherpath As String
Dim somestrFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
someotherpath = "W:\Test Folder\"
somestrFilename = Dir(someotherpath, vbNormal)
Do While somestrFilename <> ""
Dim buffer As String
Open someotherpath & somestrFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire
contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
somestrFilename = Dir()
Loop
End Sub
Private Sub DeleteExample1()
On Error Resume Next
Kill "W:\Test Folder\*.*"
On Error GoTo 0
End Sub
new Code:
Sub ISINCompiler()
'Declare Variables
Dim FSO As Object
Dim MyPath As String
Dim strFilename As String
Dim f As Object
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Destination folder\"
' Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
For Each f In FSO.GetFolder(MyPath).Files
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
'ISINCompilerx2
'DeleteExample1
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
Next f
Set f = Nothing
Set FSO = Nothing
End Sub
You can simplify your code;
Dim Filename As String
Dim lLastRow As Long
Dim wsDst As Worksheet
Set wsDst = ThisWorkbook.Worksheets("First Sheet")
Filename = Dir("W:\Test Folder\*.csv")
Do While Filename <> ""
Set wbSrce = Workbooks.Open(Filename)
lLastRow = wsDst.UsedRange.Rows.Count + 1
wbSrce.Sheets(1).UsedRange.Copy wsDst.Range("A" & lLastRow)
wbSrce.Close savechanges:=False
Filename = Dir
Loop
So i found out that Dir was the problem so i just removed dir in my main macro
Option Explicit
Public wbDst As Workbook
Public wsDst As Worksheet
Sub ISINCompiler()
'Declare Variables
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
Dim i As Long
Dim myFSO As FileSystemObject
Dim xFolder As Scripting.Folder
Dim FSO As Object
Dim f
Dim MyPath As String
Dim sDFolder As String
Application.DisplayAlerts = False
sDFolder = "W:\Destination\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myFSO = New FileSystemObject
Set xFolder = myFSO.GetFolder("C:\Source")
'Checking If File Is Located in the Source Folder
For Each f In xFolder.Files
f.Copy sDFolder & f.Name
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
ISINCompilerx2
DeleteExample1
Next f
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim lLastRow As Long
Dim somePath As String
Dim someFilename As String
handle = FreeFile
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
somePath = "W:\Destination\"
someFilename = Dir(somePath, vbNormal)
Dim buffer As String
Open somePath & someFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of
the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
End Sub
Private Sub DeleteExample1()
'You can use this to delete all the files in the folder Test
On Error Resume Next
Kill "W:\Destination\*.*"
On Error GoTo 0
End Sub

VBA code has Runtime Error with XLSM documents but not XLS

This VBA code is working for me in copying and moving XLS files but when I try to run it on an XLSM file it is telling me runtime error and is highlighting;
"CurrentWB.Sheets(SheetNumber).Select 'Selects All Worksheets in Workbook"
Run-Time Error 1004: Select Method of Worksheet Class Failed
Does anyone know what the issue might be?
Sub AutoUpdate()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False
Dim SystemPath As String
Dim FilePath As String
Dim FileName As String
Dim UtilityType As String
Dim ThisName As String
Dim FlattenedFilePath As String
Dim FlattenedFileFolder As String
Dim CurrentWB As Workbook 'Workbook Stores Workbook
SystemPath = Range("Sys.Path")
UtilityType = Range("Utility.Type")
FlattenedFileFolder = Range("Flattened.Files")
FilePath = SystemPath & UtilityType
FileName = Dir(FilePath & "\*.xls")
FlattenedFilePath = FilePath & "\" & FlattenedFileFolder
Do While FileName <> ""
Set CurrentWB = Workbooks.Open(FileName:=FilePath & "\" & FileName, UpdateLinks:=3) 'Sets CurrentWB = to that long name. This becomes the name of the workbook.
CurrentWB.RunAutoMacros Which:=xlAutoOpen 'Enables Macros in Workbook
CurrentWB.Save
ThisName = CurrentWB.Name
For SheetNumber = 1 To CurrentWB.Sheets.Count 'Counts Worksheets in Workbook
If (CurrentWB.Sheets(SheetNumber).Name <> "What If") Then
CurrentWB.Sheets(SheetNumber).Unprotect ("UMC626") 'Unprotects Workbook
With CurrentWB.Sheets(SheetNumber).UsedRange
.Value = .Value
End With
CurrentWB.Sheets(SheetNumber).Protect Password:="UMC626", DrawingObjects:=True, Contents:=True, Scenarios:=True 'Protects Workbook
End If
Next SheetNumber 'Runs Through Iteration
CurrentWB.Cells(1, 1).Select 'Saves each workbook at the top of the page
CurrentWB.SaveAs FileName:=FlattenedFilePath & "\" & ThisName
CurrentWB.Close 'Closes Workbook
FileName = Dir
Loop
End Sub

Looping through all files in a folder

I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore

Loop Through Directory VBA to Copy Data With Format

I have few files in a directory or a folder and I want to copy a range (values with format to the current sheet). I have VBA code and I think it is not in order or something is missing in the code. Please help me to fix the issue.
(I have defined named range in each files in the directory. Is it is possible to copy using the named range?)
Copy from directory files given path & from sheet2 & paste it to file "workbook.xlsm" Sheet "sheet1"
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\test"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "workbook.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Sheets("Sheet2").Select
Range("A1:N24").Copy
Workbooks.Open ("Filepath & workbook.xlsm")
If Sheets("Sheet1").Range("A1") = vbNullString Then
Sheets("Sheet1").Range ("A1:N24")
Selection.PasteSpecial Paste:=xlPasteFormats
Selection.PasteSpecial Paste:=xlPasteValues
Else
Selection.Copy Sheets("sheet1").Cells(A1, Columns.Count).End(xlToLeft).Offset(0, 1)
End If
MyFile = Dir
Loop
End Sub
One question remains:
(I have defined named range in each files in the directory. Is it is possible to copy using the named range?)
It's certainly possible. Thus assuming the Defined Name range is "DATA".
Just replace this line:
sourceWbk.Sheets("Sheet2").Range("A1:N24").Copy
with this:
sourceWbk.Sheets("Sheet2").Range("DATA").Copy
Actually, OP mentioned that this Names are generated by another procedure with the address "A1:N24". So in the case that the address is changed then there will be a need to update every other procedure that refers to it, instead by using the Defined Name don't have to worry about it as it will be taking care by design. That why it’s a good practice to use Defined Names.
I'd use this method:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim FilePath As String
Dim colFiles As Collection
Dim vFile As Variant
Dim wrkbkSource As Workbook
Dim wrkbkTarget As Workbook
Dim rngTarget As Range
FilePath = "C:\test\"
MyFile = "workbook.xlsm"
Set colFiles = New Collection
EnumerateFiles FilePath, "*.xlsm", colFiles
Set wrkbkTarget = Workbooks.Open(FilePath & MyFile)
For Each vFile In colFiles
If vFile <> FilePath & MyFile Then
Set wrkbkSource = Workbooks.Open(vFile, False)
wrkbkSource.Worksheets(1).Range("A1:N24").Copy
Set rngTarget = wrkbkTarget.Worksheets("Sheet1").Cells(1, wrkbkTarget.Worksheets("Sheet1").Columns.Count).End(xlToLeft)
rngTarget.PasteSpecial xlPasteFormats
rngTarget.PasteSpecial xlPasteValues
wrkbkSource.Close False
End If
Next vFile
End Sub
This procedure is needed to get all the files in the folder:
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
Okay see if it works for you, had to add quite a bit
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Dim targetWbk As Workbook
Dim sourceWbk As Workbook
Filepath = "C:\test"
MyFile = Dir(Filepath)
Workbooks.Open (Filepath & "\workbook.xlsm")
Set sourceWbk = ActiveWorkbook
Do While Len(MyFile) > 0
If Not MyFile = "workbook.xlsm" And MyFile = "*.xls*" Then
Workbooks.Open (Filepath & MyFile)
Set sourceWbk = ActiveWorkbook
sourceWbk.Sheets("Sheet2").Range("A1:N24").Copy
If targetWbk.Sheets("Sheet1").Range("A1") = vbNullString Then
targetWbk.Sheets("Sheet1").Range("A1:N24").PasteSpecial xlPasteFormulas, xlPasteValues
Else
targetWbk.Sheets("sheet1").Cells(A1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteFormulas, xlPasteValues
End If
MyFile = Dir
End If
Loop
End Sub

Excel VBA : Looping a simple copy of a worksheet over multiple workbooks in a folder

I'm attempting to apply a macro that would copy and paste one specific worksheet (call the title of that worksheet "x") from one workBOOK ("x1") , onto a master workBOOK (call that workBOOK "xmaster"), after it copy and pastes the worksheet from workbook x1 it should also rename the title of the worksheet "x" to cell B3. This should be done before it moves to the next workbook.
It would need to do this for workBOOK x1 through, say, x100. I cannot refer to the workbook by name though, because they are each named a string of text that is in no real sortable method.
This code I know works, copying "x" from "x1" to "xmaster", along with renaming the sheet, and breaking the links, is the following:
Sub CombineCapExFiles()
Sheets("Capital-Projects over 3K").Move After:=Workbooks("CapEx Master File.xlsm").Sheets _
(3)
ActiveSheet.Name = Range("B3").Value
Application.DisplayAlerts = False
For Each wb In Application.Workbooks
Select Case wb.Name
Case ThisWorkbook.Name, "CapEx Master File.xlsm"
' do nothing
Case Else
wb.Close
End Select
Next wb
Application.DisplayAlerts = True
End Sub
The Activate Previous window isn't working, also not sure how to fix that portion of it.
I'm not sure how to build this to loop through all workBOOKs in the directory, however.
Should I use this:?
MyPath = "C:\directory here"
strFilename = Dir(MyPath & "\*.xlsx", vbNormal) 'change to xlsm if needed ?
If Len(strFilename) = 0 Then Exit Sub ' exit if no files in folder
Do Until strFilename = ""
'Your code here
strFilename = Dir()
Loop
An additional constraint is that it needs to not run the macro on xmaster (it will have an error because it will not have the sheet "x" which will be renamed from the previous workbooks.)
Thanks!
Matthew
like this?
(not tested)
Option Explicit
Sub LoopFiles()
Dim strDir As String, strFileName As String
Dim wbCopyBook As Workbook
Dim wbNewBook As Workbook
Dim wbname as String
strDir = "C:\"
strFileName = Dir(strDir & "*.xlsx")
Set wbNewBook = Workbooks.Add 'instead of adding a workbook, set = to the name of your master workbook
wbname = ThisWorkbook.FullName
Do While strFileName <> ""
Set wbCopyBook = Workbooks.Open(strDir & strFileName)
If wbCopyBook.FullName <> wbname Then
wbCopyBook.Sheets(1).Copy Before:=wbNewBook.Sheets(1)
wbCopyBook.Close False
strFileName = Dir()
Else
strFileName = Dir()
End If
Loop
End Sub
This bit will work to avoid running the macro on xmaster.
xmaster = "filename for xmaster"
MyPath = "C:\directory here"
strFilename = Dir(MyPath & "\*.xls*", vbNormal) 'this will get .xls, .xlsx, .xlsm and .xlsb files
If Len(strFilename) = 0 Then Exit Sub ' exit if no files in folder
Do Until strFilename = ""
If strFileName = xmaster Then ' skip the xmaster file
strFilename = Dir()
End If
'Your code here
strFilename = Dir()
Loop
I can't help on the other part though. I don't see any Activate Previous window part in your code.