Transfer Data To Multiple Sheets and Add Total For Identical Items

jackjoush
NewLounger
Posts: 19
Joined: 25 Mar 2021, 21:33

Transfer Data To Multiple Sheets and Add Total For Identical Items

Post by jackjoush »

Hello everyone
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
It works fine if there's complete data ... But I am getting an error that says Run-Time '13'. Type Mismatch In this line

Code: Select all

    arrTemp(K) = arrTemp(K) + Int(arrTemp(K - 1) / 100)
In case there's no any values in any column
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
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Transfer Data To Multiple Sheets and Add Total For Identical Items

Post by HansV »

Change the line

Code: Select all

                  arrTemp(K) = arrTemp(K) + arrData(v3, K)
to

Code: Select all

                  arrTemp(K) = Val(arrTemp(K)) + Val(arrData(v3, K))
Best wishes,
Hans

jackjoush
NewLounger
Posts: 19
Joined: 25 Mar 2021, 21:33

Re: Transfer Data To Multiple Sheets and Add Total For Identical Items

Post by jackjoush »

Now it is perfect and awesome .. Thank you very much Mr. Hans