Navi_G
Board Regular
- Joined
- May 30, 2018
- Messages
- 94
- Office Version
- 2016
- Platform
- 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.
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
I guess the issue comes from your data
