Hi Experts,
I Have a VBA code that is working on a sheet but I want to apply this VBA code on multiple sheets in a folder.
I have attached my VBA code plz guide me how to use this VBA on a folder at a time.
Hi Experts,
I Have a VBA code that is working on a sheet but I want to apply this VBA code on multiple sheets in a folder.
I have attached my VBA code plz guide me how to use this VBA on a folder at a time.
Do you mean on all workbooks in a folder?
Yes Sir all workbooks in a folder.
Your code will need to open each workbook and run the code.
Is there only one sheet in each workbook?
If not is the code to run on all sheets in each workbook?
all workbooks have only one sheet
Try this
Option Explicit
Sub RunOnAllFilesInFolder()
Dim oWb As Workbook, currWs As Worksheet, currWb As Workbook
Dim sFldr As String, sFilName As String
Dim fDialog As Object
Set currWb = ActiveWorkbook
Set currWs = ActiveSheet
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
If fDialog.Show = -1 Then
sFldr = fDialog.SelectedItems(1)
Else: MsgBox "User cancelled selection"
Exit Sub
End If
''///Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
sFilName = Dir(sFldr & "\*.*")
Do While sFilName > ""
''///Update status bar to indicate progress
Application.StatusBar = "Processing " & sFldr & "\" & sFilName
Set oWb = Workbooks.Open(sFldr & "\" & sFilName)
''/// call the macro
Bundles
oWb.Close SaveChanges:=False ''///Close opened worbook w/o saving, change as needed
Debug.Print "Processed " & sFldr & "\" & sFilName
sFilName = Dir()
Loop
''///Clear statusbar and notify of macro completion
Application.StatusBar = ""
MsgBox "Completed executing macro on all workbooks"
End Sub
Sub Bundles()
Dim vWS As Worksheet
Dim vA, vA2()
Dim vR As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long
Set vWS = ActiveSheet
With vWS
vR = .Cells(Rows.Count, 4).End(xlUp).Row
vSum = Application.Sum(.Range("D2:D" & vR))
ReDim Preserve vA2(1 To vSum, 1 To 4)
vA = .Range("A2:D" & vR)
For vN = 1 To vR - 1
For vN2 = 1 To vA(vN, 4)
vC = vC + 1
For vN3 = 1 To 4
vA2(vC, vN3) = vA(vN, vN3)
Next vN3
Next vN2
Next vN
End With
vC = 1
For vN = 1 To vSum - 2
vA2(vN, 4) = vC
If vA2(vN + 1, 2) = vA2(vN, 2) Then
vC = vC + 1
vA2(vN + 1, 4) = vC
Else
vA2(vN + 1, 4) = 1
vC = 1
End If
Next vN
Application.ScreenUpdating = False
Sheets.Add
With ActiveSheet
vWS.Range("A1:D1").Copy .Range("A1:D1")
.Cells(2, 1).Resize(vSum, 4) = vA2
End With
Application.ScreenUpdating = True
End Sub
Display More
thanks a lot sir I will try it tomorrow coz now I am traveling back to home.
I've just added code to allow for the user cancelling. Make sure you use the latest version
Dear Sir,
This code is not working.
Well that's a really helpful comment!
Don’t have an account yet? Register yourself now and be a part of our community!