PDA

View Full Version : 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.:rotlaugh:
You've almost avoided VBA :wot

If only I could understand...

:clap2:

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