I have a code to Transfer Data To Multiple Sheets and Add Totals For Identical Items based on column B in data sheet
Code: Select all
Sub Test()
Dim coll As New Collection, ws As Worksheet, rng As Range, arrData, arrOut, arrTemp
Dim lastIDX As Long, I As Long, J As Long, K As Long, v1, v2, v3
Application.ScreenUpdating = False
With Sheets("data")
Set rng = .Range("A6:BH" & Application.Max(.Cells(.Rows.Count, "B").End(xlUp).Row, 8))
arrData = rng.Value
End With
For I = 3 To UBound(arrData, 1)
If Len(Trim$(arrData(I, 1))) And IsNumeric(arrData(I, 1)) Then
On Error Resume Next
coll.Add Key:=arrData(I, 60), Item:=New Collection
coll(arrData(I, 60)).Add Key:=CStr(arrData(I, 2)), Item:=New Collection
coll(arrData(I, 60))(CStr(arrData(I, 2))).Add I
On Error GoTo 0
End If
Next I
For Each v1 In coll
For Each v2 In v1
ReDim arrTemp(1 To UBound(arrData, 2))
For Each v3 In v2
For K = 2 To 40
arrTemp(K) = arrData(v3, K)
Next K
For K = 41 To 59
arrTemp(K) = arrTemp(K) + arrData(v3, K)
Next K
arrTemp(60) = arrData(v3, 60)
Next v3
For K = 42 To 58 Step 2
If K <> 56 Then
arrTemp(K) = arrTemp(K) + Int(arrTemp(K - 1) / 100)
arrTemp(K - 1) = arrTemp(K - 1) Mod 100
End If
Next K
While v2.Count
v2.Remove 1
Wend
v2.Add arrTemp
Next v2
Next v1
On Error Resume Next
For Each ws In Worksheets
Set v1 = coll(ws.Name): If Err.Number = 5 Then Err.Clear: GoTo sk1
arrOut = ws.Range("A6").CurrentRegion.Value
For I = 3 To UBound(arrOut, 1)
Set v2 = v1(CStr(arrOut(I, 2))): If Err.Number = 5 Then Err.Clear: GoTo sk2
arrTemp = v2(1)
For K = 41 To 59
arrOut(I, K) = arrOut(I, K) + arrTemp(K)
Next K
For K = 42 To 58 Step 2
If K <> 56 Then
arrOut(I, K) = arrOut(I, K) + Int(arrOut(I, K - 1) / 100)
arrOut(I, K - 1) = arrOut(I, K - 1) Mod 100
End If
Next K
v1.Remove CStr(arrOut(I, 2))
sk2: Next I
ws.Range("A6").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
If v1.Count Then
lastIDX = CLng(arrOut(UBound(arrOut, 1), 1))
ReDim arrOut(1 To v1.Count, 1 To UBound(arrOut, 2))
J = 0
For Each v2 In v1
lastIDX = lastIDX + 1
J = J + 1
arrTemp = v2(1)
arrOut(J, 1) = lastIDX
For K = 2 To 60
arrOut(J, K) = arrTemp(K)
Next K
Next v2
ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
End If
With ws.Range("A6").CurrentRegion
.Columns(59).NumberFormat = "0.00"
.Font.Name = "Times New Roman"
.Font.Bold = True
.Font.Size = "12"
End With
sk1: Next ws
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Code: Select all
arrTemp(K) = arrTemp(K) + Int(arrTemp(K - 1) / 100)
is there a way I could avoid this error message if there's no values in any column?
Please have a look at the sample workbook ...Thanks in advance