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