How to apply my VBA Code on multiple workbooks in a folder

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
Hi Experts,
I am here to find a help. I have a VBA code for my reports i want to apply this code on multiple workbooks in a folder at once is that possible if yes, pls provide a code i shall be very gratefull.

VBA Code:
Sub RefineData3()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
Debug.Print Sheets(i).Name
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
With Sheets("Result")
.Range("D2:AN2").Value = .Range("D1:AN1").Value
.Rows("1").Delete
LrD = .Range("B" & Rows.Count).End(xlUp).Row
  .Range("A1:AN" & LrD).AutoFilter Field:=3, Criteria1:="<>"
  .Range("A1:AN" & LrD).SpecialCells(xlCellTypeVisible).Copy
  .Range("A" & LrD + 1).Select
   ActiveSheet.Paste
  .Range("A1:AN" & LrD).AutoFilter
  .Rows("1:" & LrD).Delete
  .Columns(3).Delete
  
  a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Lr = .Range("A" & Rows.Count).End(xlUp).Row
  LrD = .Cells(1, Columns.Count).End(xlToLeft).Column
  Range(.Cells(1, 1), .Cells(Lr, LrD)).ClearContents
  .Range("A" & Rows.Count).End(xlUp).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
    
    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
 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "FinalResult"
   With ActiveSheet
        Sheets("Result").Range("A1:D1").Copy .Range("A1:D1")
       .Cells(2, 1).Resize(vSum, 4) = vA2
  End With
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

vds1

Well-known Member
Joined
Oct 5, 2011
Messages
1,200
You need to paste the below code on top of your existing code. Please change the path and save changes accordingly as mentioned below.

VBA Code:
Sub LoopxlsFiles()
    Dim sFile           As String
    Dim Wb              As Workbook
    Dim sPath           As String
    sPath = "C:\myfolder\" 'mention Full Path here
    sFile = Dir(sPath & "*.xls*")
    Do While Len(sFile) > 0
        Set Wb = Workbooks.Open(sPath & sFile)
        Call RefineData3
        Wb.Close True 'Make it false to omit changes
        Set Wb = Nothing
        sFile = Dir
    Loop
End Sub
 

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
Dear Sir,
I do it as per your instructions but is not working:(
 

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
Pls check this on following folder. My code is working separately but when I combine the both codes my code is also not working

Cut Detail - Google Drive
 

vds1

Well-known Member
Joined
Oct 5, 2011
Messages
1,200

ADVERTISEMENT

You need to open a fresh workbook and save the code in that workbook. Please save the file as xlsm format. Also change the below code in your refinedata3 procedure.

VBA Code:
ThisWorkbook.Sheets.Count

to

VBA Code:
Activeworkbook.sheets.count
 

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
You need to open a fresh workbook and save the code in that workbook. Please save the file as xlsm format. Also change the below code in your refinedata3 procedure.

VBA Code:
ThisWorkbook.Sheets.Count

to

VBA Code:
Activeworkbook.sheets.count
Only VBA file should be in xlsm or all sheets in folder???
 

vds1

Well-known Member
Joined
Oct 5, 2011
Messages
1,200

ADVERTISEMENT

Just the vba code should be in xlsm file.
 

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
Dear experts
Given code is not working is there any other solution for my thread??? Plz do a a help.
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
927
Office Version
  1. 2010
Platform
  1. Windows
Hi,​
maybe tomorrow once free time to check if you have committed again a wild cross posting …​
Or the faster way like any forum expects in the initial post :​
• post at least each link to each other forum where you have created the same thread - you must do the same on every forum -​
• well elaborate your need in order there is nothing to guess as after all Excel forums are not mind readers forums​
• post an accurate attachment well reflecting the before state and the expected result accordingly …​
 

Watch MrExcel Video

Forum statistics

Threads
1,132,896
Messages
5,655,850
Members
418,247
Latest member
The_aze

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top