VB macro Excel script should copy entire folder data - vba

Background : approx. 300 Excel surveys (with multiple sheets) should be centralized in 1 single excel.The macro is ready.
Goal : although the Macro is ready and able to copy the desired data from the Survey excel,I do not have the possibility to copy all 300 surveys at once ( I have to go 1 by 1 through all the surveys)
Question : is it possible to ask the macro to target copy from a specific network path and hereby to copy all the 300 excel workbooks?
Macro script :
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Sub Start()
currwb = ActiveWorkbook.Name
If bIsBookOpen("PERSONAL.XLSB") Then
Windows("PERSONAL.XLSB").Visible = True
ActiveWindow.Close
End If
If Workbooks.Count > 1 Then
MsgBox " To many files open... " & Workbooks(1).Name
Else
Application.Dialogs(xlDialogOpen).Show
Response = MsgBox("Weiter mit 'IT-Personal'?", vbYesNo)
If Response = vbYes Then
Windows(currwb).Activate
Call CopyForm
End If
End If
End Sub

To loop through files in a folder,
Sub LoopThroughFiles()
Dim path As String
Dim filename As String
Dim wb As Workbook
path = "" 'your folder path here
filename = Dir(path & "*.xls")
While (filename <> "")
Set wb = Workbooks.Open(path & filename)
'Your code goes here
wb.Close
filename = Dir
Wend
End Sub

Related

Excel VBA - Running a Macro against all files in a folder [duplicate]

I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ?
Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.
Assuming that you put your files in "Files" directory relative to your master workbook your code might look like this:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
In this example DoWork() is your macro that you apply to all of your files. Make sure that you do all your processing in your macro is always in the context of the wb (currently opened workbook).
Disclaimer: all possible error handling skipped for brevity.
A part of the question might be how do I run this on 1000 files?... Do I have to add this macro to all 1000 workbooks?
One way to do this is to add your macro's centrally to the file PERSONAL.XLSB (sometimes the extension might be different). This file will be loaded in the background every time you start Excel and makes your macro's available at any time.
Initially the PERSONAL.XLSB file will NOT be there. To automatically create this file, just start recording a "dummy" macro (with the record button on the left-bottom of a spreadsheet) and select "Personal Macro Workbook" to store it in.
After recording your macro, you can open the VBA editor with Alt+F11 and you will see the PERSONAL.XLSB file with the "dummy" recorded macro.
I use this file to store loads of general macro's which are always available, independent of which .xlsx file I have open. I have added these macro's to my own menu ribbon.
One disadvantage of this common macro file is that if you launch more than one instance of Excel, you will get an error message that the PERSONAL.XLSB file is already in use by Excel instance Nr. 1. This is no problem as long as you do not add new macro's at this moment.
Thank you very much for this
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
BSAQmacro wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
While running this code its showing bad file name or number.
i have stored my all file in ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder
Instead of passing the values to DoWork one can also run the jobs in Processfiles().
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Dim Counter As Integer
Set wb1 = ActiveWorkbook
Set PasteStart = [RRimport!A1]
Pathname = ActiveWorkbook.Path & "\For Macro to run\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb2 = Workbooks.Open(Pathname & Filename)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
wb2.Close
Filename = Dir()
Loop
End Sub
This isn't an exact answer to the question, since I was just trying to run a single script on any file that I opened and couldn't get that to work, but I thought this might help others like me. It worked once I moved the code into a Module in the Visual Basic for Applications dialog box (go to "Insert" then "Module"). Once I added my VBA code to a module, I was able to open any other file in Excel (even a CSV file) and go to Macros, and run the Macro from the other file (that contains the Module with the code) on the file that I had open.
Thanks Peterm!!
Actually, I did my macro using exactly the same code you posted (process_fiels and dowork).
It worked brilliant!! (before my question)
Each of my 1000 workbooks has 84 worksheets. My own macro (which finally works!) splits each workbook into 85 different files (the original + a short version of each worksheet saved as an individual file).
That leaves me with 1000 files + 1000x85 in the same folder, and that would be really hard to sort out.
What I really need is for Process_Files to take the first file, create a folder with the name of the first file, move the first file to the folder with ist name, then run my macro (in the folder named after the first file in the newly created folder...), go back and take the second file, create a folder with the name of the second file, move the second file to the folder with ist name, then run my macro (in the folder named after the second file in the newly created folder...), etc...
At the end, I should have moved all files into folders with the same name as the files, and the contents of the original \Files\ folder would be 1000 folders with the name of the original files, containgin the original files + 84 files which my own macro already does.
Maybe it is easier with the code:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
(Here, it should read the file name, create a folder with the file name, move the file into this newly created folder)
Set wb = Workbooks.Open(Pathname & Filename) <- open file, just as is.
DoWork wb <- do my macro,just as is
wb.Close SaveChanges:=False <- not save, to keep the original file
(go back to the original \Files\ folder)
Filename = Dir() <- Next file, just as is
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
MyMacro
End With
End Sub
Many thanks, this site is great!
__________________edit, the macro now works _________________________
As you can see, I am no VBA expert, but the macro finally works. The code is not neat at all, I am no SW programmer.
Here it is, it might help some one some day.
Sub ProcessFiles_All()
Dim Filename, Pathname, NewPath, FileSource, FileDestination As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.csv")
Do While Filename <> ""
NewPath = Pathname & Left(Filename, 34) & "\"
On Error Resume Next
MkDir (NewPath)
On Error GoTo 0
Set wb = Workbooks.Open(Pathname & Filename)
DoWorkPlease wb ' <------------ It is important to say please!!
On Error Resume Next
wb.Close SaveChanges:=False
if Err.Number <> 0 then
‘Error handler needed here
End if
Filename = Dir()
Loop
End Sub
Sub DoWorkPlease(wb As Workbook)
With wb
‘ Since my application has over 1800 cells for each column and it is time consuming
‘ I use a “testing mode” were I only play with 18 values.
Dim TestingMode As Integer
Dim ThisRange(1 To 4) As Variant
TestingMode = 0
If TestingMode = 1 Then
ThisRange(1) = "B2:CG18"
ThisRange(2) = "CT2:CT18"
ThisRange(3) = "CH2:CN18"
ThisRange(4) = "CN2:CS18"
Rows("19:18201").Select
Selection.Delete Shift:=xlUp
End If
If TestingMode = 0 Then
ThisRange(1) = "B2:CG18201"
ThisRange(2) = "CT2:CT18201"
ThisRange(3) = "CH2:CN18201"
ThisRange(4) = "CN2:CS18201"
End If
‘ speed up the macro, turn off updating and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
‘ Here is my code that manipulates the cell values from digits (values read by sensors need to be “translated” into real world values. Code not here actually.
‘Then I copy the whole thing into just numbers, there are no longer formulas, easier to work this way.
'_____________________________________
'Get just values - no more formulas
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet1").Select
Columns("A:CT").Select
Selection.Copy
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
‘ Then I save this new workbook into a folder with its own name (and under the folder \FILES\
'_____________________________________
'Save the work under its own folder
Dim CleanName, CleanPath, CleanNewName As Variant
CleanPath = ActiveWorkbook.Path
CleanName = ActiveWorkbook.Name
CleanName = Left(CleanName, 34) ‘I take out the extension
CleanPath = CleanPath + "\" + CleanName
CleanNewName = CleanPath + "\" + CleanName
CleanNewName = CleanNewName + "_clean.csv" ‘ and I add “clean” to have a different name now.
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False
‘If there is an error I create an empty folder with the name of the file to know which file needs rework.
If Err.Number <> 0 Then
MkDir (CleanPath + "_error_" + CleanName)
End If
'Resume Next
ActiveSheet.Move _
After:=ActiveWorkbook.Sheets(1)
‘ Then I split the workbook into individual files with the data I need for individual sensors.
‘ Here are the individual ranges I need for each file. Since I have over 1000 files, it is worth the effort.
'_______________ the Split!!______________________________
Dim Col(1 To 98) As Variant
Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT"
Col(2) = "A:A,C:C,CH:CH,CN:CN,CT:CT"
Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT"
Col(4) = "A:A,E:E,CH:CH,CN:CN,CT:CT"
Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT"
Col(6) = "A:A,G:G,CH:CH,CN:CN,CT:CT"
Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT"
Col(8) = "A:A,I:I,CH:CH,CN:CN,CT:CT"
Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT"
Col(10) = "A:A,K:K,CH:CH,CN:CN,CT:CT"
Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT"
Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT"
Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT"
Col(14) = "A:A,O:O,CH:CH,CN:CN,CT:CT"
Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT"
Col(16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT"
Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT"
Col(18) = "A:A,S:S,CI:CI,CO:CO,CT:CT"
Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT"
Col(20) = "A:A,U:U,CI:CI,CO:CO,CT:CT"
Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT"
Col(22) = "A:A,W:W,CI:CI,CO:CO,CT:CT"
Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT"
Col(24) = "A:A,Y:Y,CI:CI,CO:CO,CT:CT"
Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT"
Col(26) = "A:A,AA:AA,CI:CI,CO:CO,CT:CT"
Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT"
Col(28) = "A:A,AC:AC,CI:CI,CO:CO,CT:CT"
Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT"
Col(30) = "A:A,AE:AE,CJ:CJ,CP:CP,CT:CT"
Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT"
Col(32) = "A:A,AG:AG,CJ:CJ,CP:CP,CT:CT"
Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT"
Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT:CT"
Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT"
Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP,CT:CT"
Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT"
Col(38) = "A:A,AM:AM,CJ:CJ,CP:CP,CT:CT"
Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT"
Col(40) = "A:A,AO:AO,CJ:CJ,CP:CP,CT:CT"
Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT"
Col(42) = "A:A,AQ:AQ,CJ:CJ,CP:CP,CT:CT"
Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT"
Col(44) = "A:A,AS:AS,CK:CK,CQ:CQ,CT:CT"
Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT"
Col(46) = "A:A,AU:AU,CK:CK,CQ:CQ,CT:CT"
Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT"
Col(48) = "A:A,AW:AW,CK:CK,CQ:CQ,CT:CT"
Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT"
Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ,CT:CT"
Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT"
Col(52) = "A:A,BA:BA,CK:CK,CQ:CQ,CT:CT"
Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT"
Col(54) = "A:A,BC:BC,CK:CK,CQ:CQ,CT:CT"
Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT"
Col(56) = "A:A,BE:BE,CK:CK,CQ:CQ,CT:CT"
Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT"
Col(58) = "A:A,BG:BG,CL:CL,CR:CR,CT:CT"
Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT"
Col(60) = "A:A,BI:BI,CL:CL,CR:CR,CT:CT"
Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT"
Col(62) = "A:A,BK:BK,CL:CL,CR:CR,CT:CT"
Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT"
Col(64) = "A:A,BM:BM,CL:CL,CR:CR,CT:CT"
Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT"
Col(66) = "A:A,BO:BO,CL:CL,CR:CR,CT:CT"
Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT"
Col(68) = "A:A,BQ:BQ,CL:CL,CR:CR,CT:CT"
Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT"
Col(70) = "A:A,BS:BS,CL:CL,CR:CR,CT:CT"
Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT"
Col(72) = "A:A,BU:BU,CM:CM,CS:CS,CT:CT"
Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT"
Col(74) = "A:A,BW:BW,CM:CM,CS:CS,CT:CT"
Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT"
Col(76) = "A:A,BY:BY,CM:CM,CS:CS,CT:CT"
Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT"
Col(78) = "A:A,CA:CA,CM:CM,CS:CS,CT:CT"
Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT"
Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT"
Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT"
Col(82) = "A:A,CE:CE,CM:CM,CS:CS,CT:CT"
Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT"
Col(84) = "A:A,CG:CG,CM:CM,CS:CS,CT:CT"
‘ I want to split 84 new files, so for testing I use only 1, and for the real thing I go with 84
Dim CounterMode As Integer
If TestingMode = 1 Then CounterMode = 1 Else CounterMode = 84
For i = 1 To CounterMode
‘ this code takes the columns need, and paste it into a new workbook.
Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents
Range("A1").Activate
Sheets(2).Select
Range(Col(i)).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:E").EntireColumn.AutoFit
‘ Save the individual file
'_____________save the work________________
Dim ThePath, TheName, TheSwitch As String
ThePath = ActiveWorkbook.Path + “\”
TheName = Left(ActiveWorkbook.Name, 34) ‘ take out the extension from the name
ThePath = ThePath + TheName
TheSwitch = Cells(3, 2) ‘ In Cell (3,2) I have the name of the individual name, so I added to the file name.
TheName = ThePath + "_" + TheSwitch + ".xls"
Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
Dim SheetName As Variant
‘ I name Sheets(1) as Sheet1, since the original sheet has the name and date of the test.
‘ I do this to have the same name on all file in order to do a plot, then I rename the sheet with the
‘ original name
SheetName = ActiveSheet.Name
ActiveWorkbook.Sheets(1).Name = "Sheet1"
‘ here is the plot
Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
ActiveWorkbook.Sheets(1).Name = SheetName
‘save
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False
If Err.Number <> 0 Then
MkDir (ThePath + "_error_" + TheName)
End If
ActiveWorkbook.Close
Next i
'____________________That was the Split__________________________________
' Turn on screenupdating:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A1").Select
End With
End Sub

Convert .txt file to .xlsx & remove unneeded rows & format columns correctly

I've got a folder which contains .txt files (they contain PHI, so I can't upload the .txt file, or an example without PHI, or even any images of it). I need an excel macro, which will allow the user to choose the folder containing the file, and will then insert the .txt file data into a new excel workbook, format the rows and columns appropriately, and finally save the file to the same folder that the source was found in.
So far I've got all of that working except for the formatting of rows and columns. As of now, the .txt data is inserted to a new workbook & worksheet, but I can't seem to figure out how to get rid of rows I don't need, or how to get the columns formatted appropriately.
Again, I can't upload the .txt file (or anything) because the Healthcare organization I work for blocks it - even if I've removed all PHI.
Below is the macro I've created so far:
Private Sub CommandButton2_Click()
On Error GoTo err
'Allow the user to choose the FOLDER where the TEXT file(s) are located
'The resulting EXCEL file will be saved in the same location
Dim FldrPath As String
Dim fldr As FileDialog
Dim fldrChosen As Integer
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder containing the Text File(s)"
.AllowMultiSelect = False
.InitialFileName = "\\FILELOCATION"
fldrChosen = .Show
If fldrChosen <> -1 Then
MsgBox "You Chose to Cancel"
Else
FldrPath = .SelectedItems(1)
End If
End With
If FldrPath <> "" Then
'Make a new workbook
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add
'Make worksheet1 of new workbook active
newWorkbook.Worksheets(1).Activate
'Completed files are saved in the chosen source file folder
Dim CurrentFile As String: CurrentFile = Dir(FldrPath & "\" & "*.txt")
Dim strLine() As String
Dim LineIndex As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While CurrentFile <> vbNullString
'How many rows to place in Excel ABOVE the data we are inserting
LineIndex = 0
Close #1
Open FldrPath & "\" & CurrentFile For Input As #1
While Not EOF(1)
'Adds number of rows below the inserted row of data
LineIndex = LineIndex + 1
ReDim Preserve strLine(1 To LineIndex)
Line Input #1, strLine(LineIndex)
Wend
Close #1
With ActiveSheet.Range("A1").Resize(LineIndex, 1)
.Value = WorksheetFunction.Transpose(strLine)
.TextToColumns Other:=True, OtherChar:="|"
End With
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Name = Replace(CurrentFile, ".txt", "")
ActiveWorkbook.SaveAs FldrPath & "\" & Replace(CurrentFile, ".txt", ".xls"), xlNormal
ActiveWorkbook.Close
CurrentFile = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Done:
Exit Sub
err:
MsgBox "The following ERROR Occurred:" & vbNewLine & err.Description
ActiveWorkbook.Close
End Sub
Any ideas of how I can delete entire lines from being brought into excel?
And how I can format the columns appropriately? So that I'm not getting 3 columns from the .txt file all jammed into 1 column in the resulting excel file?
Thanks
I'd recommend you not to re-invent the wheel. Microsoft provides an excellent add-on to accomplish this task, Power Query.
It lets you to load every file in a folder and process it in bulks.
Here you have a brief introduction of what can do for you.

Running List of CMD lines from Excel

Can anyone help please with the following requirements?
Requirement A:
I'd like to create a loop to run a list of command strings in CMD as long as there's a non-zero value in column C. I think I need to define a variable i for my starting row as this will always be the same, and then run Shell(), pulling the command string from the corresponding cell in Row i, Column F. While Cells(i, "C") is not blank, keep going, increasing i by 1.
Requirement B:
I'd also like to link this macro to work in a directory deposited in a cell by an earlier macro that listed all the files in a selected directory.
This is what I have, without any looping..
Sub Run_Renaming()
Dim CommandString As Long
Dim i As Integer
i = 5
'Other steps:
'1 - need to pick up variable (directory of files listed, taken from first macro
'when doing manually, I opened command, went to correct directory, then pasted
'the commands. I'm trying to handle pasting the commands. I'm not sure if I need
'something to open CMD from VBA, then run through the below loop, or add opening
'CMD and going to the directory in each iteration of the below loop...
'2 - Need to say - Loop below text if Worksheets("Batch Rename of Files").Cells(i, "C").Value is no blank
CommandString = Worksheets("Batch Rename of Files").Cells(i, "F").Value
Call Shell("cmd.exe /S /K" & CommandString, vbNormalFocus)
'Other steps:
'3 - need to increase i by 1
'4 - need to check if C column is blank or not
'5 - need to end of C column is blank
End Sub
Background:
I'm creating a file renaming tool for a friend. They can use excel, but no programming languages or command prompt. Because of this, I don't want to have any steps, like creating a batch file suggested here, that would complicate things for my friend.
I've created an excel file with:
Tab 1 - a template sheet to create a new file name list. Works by concatenating several cells, adding a filetype, and outputting to a range of cells. Tab two links to this range when creating the renaming command strings for CMD
Tab 2 -
Button 1 - Sub rename() below. VBA to list files in a selected directory in Column C
Column F creates a command line that will rename File A as File B based on inputs to Tab 1 i.e. ren "File 1" "A1_B1_C1.xlsx"
Button 2 - Refers to a renaming macro (requirement 1 and 2 above) that picks up the selected directory from Button 1 and runs through all the renaming command strings while in that directory
Sub rename()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
Worksheets("Batch Rename of Files").Activate
Worksheets("Batch Rename of Files").Range("C4").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
Caveats:
1) I am not entirely clear on how you data etc is laid out so i am offering a way of achieving your goal that involves the elements i am clear on.
2) To be honest, personally, i would do as much using arrays or a dictionary as possible rather than going backwards and forwards to worksheets.
However...
Following the outline of your requirements and a little rough and ready, we have:
1) Using your macro rename (renamed as ListFiles and with a few minor tweaks) to write the chosen folder name out to Range("A1") in Worksheets("Batch Rename of Files") and the file names to Column C.
2) Using a second macro RenameFiles to pick up the rename shell commands from Column F of Worksheets("Batch Rename of Files"); write these out to a batch file on the desktop; add an additional first line command that sets the working directory to the chosen folder given in Range("A1") (Requirement A). The shell command executes the .bat file, completes the renaming (Requirement B) and then there is a line to remove the .bat file.
I am guessing this is a more efficient way of achieving your goal than looping the column F range executing a command one at a time.
I have not sought to optimize code in any further ways (i have added a few existing typed functions.) There are a number of other improvements that could be made but this was intended to help you achieve your requirements.
Let me know how it goes!
Tab1 layout (Sheet containing new file names):
Batch Rename of Files layout (Sheet containing output of the first macro and the buttons ):
Layout of Worksheet Batch Rename of File
In a standard module called ListFiles:
Option Explicit
Public Sub ListFilesInDirectory()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$ 'type hints not really needed
Dim wb As Workbook
Dim wsTab2 As Worksheet
Set wb = ThisWorkbook
Set wsTab2 = wb.Worksheets("Batch Rename of Files")
InitialFoldr$ = "C:\"
Dim lastRow As Long
lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row
wsTab2.Range("C4:C" & lastRow).ClearContents 'Get rid of any existing file names
wsTab2.Range("C4").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
wsTab2.Range("A1") = xDirect$
Do While xFname$ <> vbNullString
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
In a standard module called FileRenaming:
Option Explicit
Sub RenameFiles()
Dim fso As New FileSystemObject
Dim stream As TextStream
Dim strFile As String
Dim strPath As String
Dim strData As Range
Dim wb As Workbook
Dim wsTab2 As Worksheet
Dim currRow As Range
Set wb = ThisWorkbook
Set wsTab2 = wb.Worksheets("Batch Rename of Files")
strPath = wsTab2.Range("A1").Value2
If strPath = vbNullString Then
MsgBox "Please ensure that Worksheet Batch Rename of Files has a directory path in cell A1"
Else
If Right$(Trim$(strPath), 1) <> "\" Then strPath = strPath & "\"
strFile = "Rename.bat"
Dim testString As String
Dim deskTopPath As String
deskTopPath = Environ$("USERPROFILE") & "\Desktop" 'get desktop path as this is where .bat file will temporarily be saved
testString = fso.BuildPath(deskTopPath, strFile) 'Check if .bat already exists and delete
If Len(Dir(testString)) <> 0 Then
SetAttr testString, vbNormal
Kill testString
End If
Set stream = fso.CreateTextFile(deskTopPath & "\" & strFile, True) 'create the .bat file
Dim lastRow As Long
lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row
Set strData = wsTab2.Range("F4:F" & lastRow) 'Only execute for as many new file names as present in Col C (in place of your until blank requirement)
stream.Write "CD /D " & strPath & vbCrLf
For Each currRow In strData.Rows 'populate the .dat file
stream.Write currRow.Value & vbCrLf
Next currRow
stream.Close
Call Shell(testString, vbNormalFocus)
Application.Wait (Now + TimeValue("0:00:01")) 'As sometime re-naming doesn't seem to happen without a pause before removing .bat file
Kill testString
MsgBox ("Renaming Complete")
End If
End Sub
Buttons code in Worksheet Batch Rename of Files
Private Sub CommandButton1_Click()
ListFilesInDirectory
End Sub
Private Sub CommandButton2_Click()
RenameFiles
End Sub
Example .bat file contents:
VERSION 2
And here is a different version using a dictionary and passing parameters from one sub to another. This would therefore be a macro associated with only one button push operation i.e. there wouldn't be a second button. The single button would call ListFiles which in turn calls the second macro. May require you to go in to tools > references and add in Microsoft Scripting Runtime reference.
Assumes you have a matching number of new file names in Col D of tab 1 as the number of files found in the folder (as per your script to obtain files in folder). I have removed the obsolete type references.Shout out to the RubberDuck VBA add-in crew for the add-in picking these up.
In one standard module:
Option Explicit
Public Sub ListFiles()
Dim xDirect As String, xFname As String, InitialFoldr As String
Dim wb As Workbook
Dim ws As Worksheet
Dim dict As New Scripting.Dictionary
Dim counter As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Tab1") 'Worksheet where new file names are
counter = 4 'row where new file names start
InitialFoldr = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr
.Show
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
xFname = Dir(xDirect, 7)
Do While xFname <> vbNullString
If Not dict.Exists(xFname) Then
dict.Add xFname, ws.Cells(counter, "D") 'Or which ever column holds new file names. This add to the dictionary the current name and new name
counter = counter + 1
xFname = Dir
End If
Loop
End If
End With
RenameFiles xDirect, dict 'pass directory path and dictionary to renaming sub
End Sub
In another standard module:
Public Sub RenameFiles(ByVal folderpath As String, ByRef dict As Dictionary)
Dim fso As New FileSystemObject
Dim stream As TextStream
Dim strFile As String
Dim testString As String
Dim deskTopPath As String
strFile = "Rename.bat"
deskTopPath = Environ$("USERPROFILE") & "\Desktop"
testString = fso.BuildPath(deskTopPath, strFile)
'See if .dat file of same name already on desktop and delete (you could overwrite!)
If Len(Dir(testString)) <> 0 Then
SetAttr testString, vbNormal
Kill testString
End If
Set stream = fso.CreateTextFile(testString, True)
stream.Write "CD /D " & folderpath & vbCrLf
Dim key As Variant
For Each key In dict.Keys
stream.Write "Rename " & folderpath & key & " " & dict(key) & vbCrLf 'write out the command instructions to the .dat file
Next key
stream.Close
Call Shell(testString, vbNormalFocus)
Application.Wait (Now + TimeValue("0:00:01")) 'As sometime re-naming doesn't seem to happen without a pause before removing .bat file
Kill testString
' MsgBox ("Renaming Complete")
End Sub
Scripting run time reference:
Adding runtime reference
Additional method for finding the desktop path. Taken from Allen Wyatt:
In a standard module add the following:
Public Function GetDesktop() As String
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
GetDesktop = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
End Function
Then in the rest of the code replace any instances of deskTopPath =..... e.g.:
deskTopPath = Environ$("USERPROFILE") & "\Desktop"
With
desktopPath = GetDesktop

VBA kill crashes after being called by auto_open

I'm experiencing some trouble with my VBA code. I have created an application in Excel and its copies have been distributed to users. To be able to correct bugs or add some new functions, every copy stores information what version it is. I have written procedure, that opens (read-only) a central file, that is providing some data a and information, which version is current. If the file, that opened this central file is older, it gets updated.
So the auto_open calls a procedure discovers that it has to be updated, saves the current file AS FileName_old.xlsm (to have some backup), kills the FileName.xlsm and copies a new file from a template. The problem is that the procedure crashes when it tries to kill the old file (to be more precise, it just ends without any error message). What confuses me is that when I run the auto_open macro manually (F5), everything goes correctly. Even step by step goes right. Also, when I call the update process via a button in a worksheet, it works perfectly. Any idea, what might cause this problem?
Thanks
Sub auto_open()
If Range("H_User").Value = "" Then UserNameWindows 'Write a user that is using this workbook in the range H_User
If Range("H_Updated").Value < FileDateTime(Range("H_File_Data").Value) Then UpdateData
End Sub
Sub UpdateData()
Dim ActWB As String
ActWB = ActiveWorkbook.Name
Application.ScreenUpdating = False
ThisWorkbook.Activate
If Not FileExists(Range("H_File_Data").Value) Then
MsgBox "The data file is not available!", vbCritical
Workbooks(ActWB).Activate
Application.ScreenUpdating = True
Exit Sub
End If
Dim WB As String, oknoData As String, IsTeam As Boolean, User As String
Dim version As Integer, Subversion As Integer, DataPath As String
On Error GoTo konec
Application.EnableCancelKey = xlDisabled
IsTeam = False
User = Range("H_User").Value
WB = ActiveWindow.Caption
version = Range("H_version").Value
Subversion = Range("H_Subversion").Value
Range("C_Data_All").ClearContents
DataPath = Range("H_File_Data").Value
Workbooks.Open fileName:=DataPath, ReadOnly:=True
oknoData = ActiveWindow.Caption
If Range("H_version_Spec").Value <= version Or (Range("H_version_Spec").Value = version And Range("H_Subversion_Spec").Value <= Subversion) Then
FileUpdate
End If
'If there is no need to update the file then continue with in this procedure
End Sub
Sub FileUpdate()
Dim NewPath As String, NewWB As String, OldPath As String, OldWB As String, BackupWB As String, BackupPath As String
Dim MainWB As String, version As String, Subversion As String
Dim versionMax As Integer, SubversionMax As Integer, versionMin As Integer, SubversionMin As Integer
ThisWorkbook.Activate
version = Range("H_version").Value
Subversion = Range("H_Subversion").Value
OldPath = ThisWorkbook.FullName
OldWB = ThisWorkbook.Name
BackupWB = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "_old.xlsm"
BackupPath = ThisWorkbook.Path & "\" & BackupWB
If Not FileExists(Workbooks(OldWB).Names("H_File_Data").RefersToRange.Value) Then
MsgBox "The data file is not available!", vbCritical
Exit Sub
End If
Workbooks.Open fileName:=Workbooks(OldWB).Names("H_File_Data").RefersToRange.Value, ReadOnly:=True
MainWB = ActiveWorkbook.Name
If version = Range("O_Spec_version").Value And Subversion >= Range("O_Spec_Subversion").Value Then
'Just some little piece of code if the version is not lower
Else
If FileExists(BackupPath) Then Kill (BackupPath)
If Not FileExists(Range("H_Path_Spec_Actual").Value) Then
MsgBox "The spec template is not available!", vbCritical
Exit Sub
End If
ThisWorkbook.SaveAs BackupPath
Kill (OldPath)
'Continue with update
End If
End Sub
Function FileExists(FilePath As String) As Boolean
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
FileExists= fso.FileExists(FilePath)
End Function
Option Explicit
Private Sub Workbook_Open()
Dim BackupPath As String
Dim OldPath As String
BackupPath = "folder\Filename_old.xlsm"
With ThisWorkbook
OldPath = .FullName
.SaveCopyAs BackupPath
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
End Sub

VBA Function to return the value only when File can be opened without any error

I'm writing an Excel VBA code to Check how many files in a folder are corrupt.
A folder named as 'Folder' in 'E' drive has these pdf files.
In my workbook; Column A of Sheet1 has fileNames from this folder.
I have a code which loops through the filesNames from column A and opens those.
My objective is : If the file can be opened; then don't print anything in the adjacent cell (of column B) else print as 'Corrupt'.
But, when I run this VBA code; as each time loop goes to the Function OpenPDFPage(), it do not print anything in the adjacent cell of column B.
(I want to print it only when the file is corrupt and I get message box saying "There was an error opening this document. The file is damaged and could not be repaired")
Can I know what change I've to make to the Function OpenPDFPage() so that, when there is a corrupt file (or the file which can't be opened) in folder; then only code will print "corrupt" in the adjacent cell of column B.
The code is as below:
Option Explicit
Function OpenPDFPage(PDFPath As String) As Boolean
On Error GoTo Error_OpenPDFPage
ThisWorkbook.FollowHyperlink PDFPath, NewWindow:=True
OpenPDFPage = True
Exit_OpenPDFPage:
Exit Function
Error_OpenPDFPage:
MsgBox Err & ": " & Err.Description
OpenPDFPage = False
Resume Exit_OpenPDFPage
End Function
Sub Test()
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2:A" & lastRow)
MyFile = MyFolder & "\" & filename
If OpenPDFPage(MyFile) = True Then
'Do Nothing
Else
filename.Offset(0, 1).Value = "Corrupt"
End If
Next
End Sub
Added another macro to the above; to check whether the file is opened;
If it's not opened through previous macro, then am assuming it's corrupt;
and printing in adjacent cell of column B as 'Corrupt'.
Sub IsFileOpened()
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A1:A" & lastRow)
MyFile = MyFolder & "\" & filename
If IsFileOpen(MyFile) = True Then
' Do Nothing
Else
filename.Offset(0, 1).Value = "Corrupt"
End If
Next
End Sub
Function IsFileOpen(filename As String) As Boolean
Dim filenum As Integer, errnum As Integer
On Error Resume Next
filenum = FreeFile()
'Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
' Another error occurred.
'Case Else
'Error errnum
End Select
End Function