Running macro on files in a folder: impossibly hard!

**sparkerino** · 11-15-2019, 01:41 PM

Hello,

I have tried a ton of different codes, video tutorials and resources to try and run my code on all of the .xls files in a folder, and cannot get it to work. I know this should be trivial, and it's likely that my lack of experience with VBA is making me miss something obvious, so I really appreciate anyone's patient assistance with this.

I'm running Excel 2016 on a Mac running Mojave. I want to run the following code on the files in the path /Users/sara/Desktop/MatLab/Split Files/ . I just want it to open the file, run the macro, save/overwrite the original file, and close. Thank you for your help

Sub DataReorganization()


'Duplicating Sheet to TIPS
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    On Error Resume Next
    ActiveSheet.Name = "TIPS"
    
'Editing Columns
Sheets("TIPS").Select
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("I3").Select
    ActiveCell.FormulaR1C1 = "1"
   Dim rng As Range
Dim sht As Worksheet
Dim Lastrow As Long
Lastrow = Range("A" & Rows.Count).End(xlUp).Row   '
Set rng = Range("H4:H" & Lastrow)
rng.Formula = "=IF(A4=A3,H3,H3+1)"
Set rng = Range("I4:I" & Lastrow)
rng.Formula = "= IF(A4=A3,I3+1,1)"
    Columns("H:I").Select
    Selection.Copy
    Columns("A:B").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("H:I").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Value = "Filo"
Range("B1").Value = "Time"
Range("C1").Value = "X"
Range("D1").Value = "Y"
Range("E1").Value = "Distance"
Range("F1").Value = "Velocity"
Range("G1").Value = "Intensity"


    
'Duplicating TIPS to IDENTIFIERS
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    On Error Resume Next
    ActiveSheet.Name = "IDENTIFIERS"
    
'Delete Time
Sheets("IDENTIFIERS").Select
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Columns("E:H").Select
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    ActiveWorkbook.Worksheets("IDENTIFIERS").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("IDENTIFIERS").Sort.SortFields.Add2 Key:=Range( _
        "B2:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("IDENTIFIERS").Sort
        .SetRange Range("A:D")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Dim iCntr As Long
    For iCntr = Lastrow To 1 Step -1
        If Cells(iCntr, 2).Value <> "1" Then
            Rows(iCntr).Delete
        End If
    Next
    Range("A1").EntireRow.Insert
    Range("A1").Value = "Filo"
Range("B1").Value = "Time"
Range("C1").Value = "X"
Range("D1").Value = "Y"
    
'Create Sheet BASES
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "BASES"
End Sub
'Save All
For Each Workbook In Workbooks
Workbook.SaveAs fileName:= _
        "/Users/sara/Desktop/MatLab/Split Files/" & Workbook.Name, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False


Next
End Sub

**paulked** · 11-15-2019, 02:22 PM

I've corrected some basic errors in the code but haven't run it because a) you don't give any clue as to where it is going wrong and b) I've never used a MAC so I've no idea of the file/folder/directory structure!

Sub DataReorganization()


    Dim wb As Workbook
    'Duplicating Sheet to TIPS
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    On Error Resume Next
    ActiveSheet.Name = "TIPS"


    'Editing Columns
    Sheets("TIPS").Select
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("I3").Select
    ActiveCell.FormulaR1C1 = "1"
    Dim rng As Range
    Dim sht As Worksheet
    Dim Lastrow As Long
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row '
    Set rng = Range("H4:H" & Lastrow)
    rng.Formula = "=IF(A4=A3,H3,H3+1)"
    Set rng = Range("I4:I" & Lastrow)
    rng.Formula = "= IF(A4=A3,I3+1,1)"
    Columns("H:I").Select
    Selection.Copy
    Columns("A:B").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("H:I").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Value = "Filo"
    Range("B1").Value = "Time"
    Range("C1").Value = "X"
    Range("D1").Value = "Y"
    Range("E1").Value = "Distance"
    Range("F1").Value = "Velocity"
    Range("G1").Value = "Intensity"






    'Duplicating TIPS to IDENTIFIERS
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    On Error Resume Next
    ActiveSheet.Name = "IDENTIFIERS"


    'Delete Time
    Sheets("IDENTIFIERS").Select
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Columns("E:H").Select
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    ActiveWorkbook.Worksheets("IDENTIFIERS").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("IDENTIFIERS").Sort.SortFields.Add2 Key:=Range( _
        "B2:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
    With ActiveWorkbook.Worksheets("IDENTIFIERS").Sort
        .SetRange Range("A")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Dim iCntr As Long
    For iCntr = Lastrow To 1 Step -1
        If Cells(iCntr, 2).Value <> "1" Then
            Rows(iCntr).Delete
        End If
    Next
    Range("A1").EntireRow.Insert
    Range("A1").Value = "Filo"
    Range("B1").Value = "Time"
    Range("C1").Value = "X"
    Range("D1").Value = "Y"


    'Create Sheet BASES
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "BASES"
    'End Sub
    'Save All
    For Each wb In Workbooks
        wb.SaveAs Filename:= _
        "/Users/sara/Desktop/MatLab/Split Files/" & wb.Name, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False




    Next
End Sub

**SamT** · 11-15-2019, 08:58 PM

My offering

Option Explicit

Sub DataReorganization()
Dim rng As Range
Dim sht As Worksheet
Dim Lastrow As Long
Dim iCntr As Long


'Duplicating Sheet to TIPS
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = "TIPS"

'Editing Columns
With Sheets("TIPS")
   Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

   .Range("H3").FormulaR1C1 = "1"
   .Range("I3").FormulaR1C1 = "1"

   Lastrow = Range("A" & Rows.Count).End(xlUp).Row '
   Set rng = Range("H4:H" & Lastrow)
   rng.Formula = "=IF(A4=A3,H3,H3+1)"
   
   Set rng = Range("I4:I" & Lastrow)
   rng.Formula = "= IF(A4=A3,I3+1,1)"
   
   Columns("H:I").Copy
   Columns("A:B").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
   Application.CutCopyMode = False
   Columns("H:I").Delete Shift:=xlToLeft

   Rows("1:1").Delete Shift:=xlUp
   Range("A1").Value = "Filo"
   Range("B1").Value = "Time"
   Range("C1").Value = "X"
   Range("D1").Value = "Y"
   Range("E1").Value = "Distance"
   Range("F1").Value = "Velocity"
   Range("G1").Value = "Intensity"
End With


'Duplicating TIPS to IDENTIFIERS
Sheets("TIPS").Copy After:=Worksheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = "IDENTIFIERS"

'Delete Time
With Sheets("IDENTIFIERS")
   Lastrow = Range("A" & Rows.Count).End(xlUp).Row
   Rows("1:1").Delete Shift:=xlUp
   Columns("E:H").Delete Shift:=xlToLeft
   
   Cells.Select
   ActiveWorkbook.Worksheets("IDENTIFIERS").Sort.SortFields.Clear
   ActiveWorkbook.Worksheets("IDENTIFIERS").Sort.SortFields.Add2 Key:=Range( _
      "B2:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
      xlSortNormal
   .Sort '-------SortOn:=xlSortOnValues Must be a Mac thing
   
   .SetRange .Range("A:D") '-------------???? Mac Only? I don't know
   .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
   'End With '--------------------------???
   
   For iCntr = Lastrow To 1 Step -1
      If Cells(iCntr, 2).Value <> "1" Then
         Rows(iCntr).Delete
      End If
   Next
   
   Range("A1").EntireRow.Insert
   Range("A1").Value = "Filo"
   Range("B1").Value = "Time"
   Range("C1").Value = "X"
   Range("D1").Value = "Y"
End With

'Create Sheet BASES
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "BASES"
'End Sub '------------------------------------???

'Save All
For Each Workbook In Workbooks
   Workbook.SaveAs Filename:= _
   "/Users/sara/Desktop/MatLab/Split Files/" & Workbook.Name, FileFormat:= _
   xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
   , CreateBackup:=False
Next
End Sub

**snb** · 11-16-2019, 06:22 AM

Sub M_snb()
    Sheet1.Copy , Sheets(Sheets.Count)

    With Sheets(Sheets.Count)
       .Name = "TIPS"
       sn = .Cells(1).CurrentRegion.Resize(, 2)
       ReDim sp(UBound(sn), 1)
       
       sp(3, 0) = 1
       sp(3, 1) = 1
       For j = 4 To UBound(sn)
          sp(j, 0) = IIf(sn(j - 1, 1) = sn(j, 1), sp(j - 1, 0), sp(j - 1, 0) + 1)
          sp(j, 1) = IIf(sn(j - 1, 1) = sn(j, 1), sp(j - 1, 1) + 1, sp(j - 1, 1))
       Next
       .Cells(1).CurrentRegion.Resize(, 2) = sp
       .Cells(1).Resize(, 7) = Split("Filo Time X Y Distance Velocity Intensity")
    End With
End Sub

Avoid 'Select' and 'Activate' in VBA.

**paulked** · 11-16-2019, 08:07 AM

Avoid 'Select' and 'Activate' in VBA.

Brilliant.

You've almost avoided VBA

If only I could understand...

**snb** · 11-16-2019, 10:01 AM

Take your time.
see also: http://www.snb-vba.eu/VBA_Arrays_en.html

**paulked** · 11-16-2019, 10:17 AM

Wow, great site! I've got some serious reading to do...

**sparkerino** · 11-16-2019, 11:09 AM

Sorry, everyone, for not being clear. The code that I posted works fine on its own, but I cannot figure out how to combine it with other posted examples of how to apply the code to a folder for batch processing. For example, below (however this specific example gives an error "Object variable or With block variable not set" at fDialog.Title = "Select a folder" )

It might be that most examples out there just do not work with Mac directory structure or something, so I'll test some things out on a PC at work before asking for help or posting again.

Sub RunOnAllFilesInFolder()
    Dim folderName As String, eApp As Excel.Application, fileName As String
    Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
    Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
 
    'Select folder in which all files are stored
    fDialog.Title = "Select a folder"
    fDialog.InitialFileName = currWb.path
    If fDialog.Show = -1 Then
      folderName = fDialog.SelectedItems(1)
    End If
    
    
    'Create a separate Excel process that is invisibile
    Set eApp = New Excel.Application:  eApp.Visible = False
    
    'Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
    fileName = Dir(folderName & "\*.xls")
    Do While fileName <> ""
        'Update status bar to indicate progress
        Application.StatusBar = "Processing " & folderName & "" & fileName
 
 
        Set wb = eApp.Workbooks.Open(folderName & "" & fileName)
        '...
        'YOUR CODE HERE
        '...
        wb.Close SaveChanges:=False 'Close opened worbook w/o saving, change as needed
        Debug.Print "Processed " & folderName & "" & fileName
        fileName = Dir()
    Loop
    eApp.Quit
    Set eApp = Nothing
    'Clear statusbar and notify of macro completion
    Application.StatusBar = ""
    MsgBox "Completed executing macro on all workbooks"
End Sub

**SamT** · 11-16-2019, 08:59 PM

error "Object variable or With block variable not set" at fDialog.Title = "Select a folder" )

That means the error is in the Set fDialog line

Thread: Running macro on files in a folder: impossibly hard!

Thread Tools

Display

Running macro on files in a folder: impossibly hard!

Tags for this Thread

Posting Permissions