CODEWITHSUNDEEP
arraysvbaexcelalignment
EnnaSmile
EnnaSmile

Reputation: 103

Using VBA arrays to synchronize three sheets into one

I managed to sync selected data from three sheets into a fourth sheet. But the data doesn't align properly after empty cells beginning with the 14th row.

Now I'm trying to use arrays to align my data better. I have 3 sheets with columns Area, Zone, Employee and 6 numeric columns for each employee.

The data in Area, Zone & Employee is repeating itself in multiple rows so I need to add the numbers for every employee to have the Employee Name displayed only once with added data in other 6 columns.

I don't really have problem with filtering the names and adding data, but I'm not sure how to do it using arrays.

Or if anyone could help me find a mistake in my code that's causing the data to not align properly, I would also appreciate it. Below is my code so far, hopefully it would help.

Private Sub cmd_button1_Click()
    Dim WS1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Set WS1 = Sheets("Sheet2")
    Set ws2 = Sheets("Distribution")
    Set ws3 = Sheets("Sheet3")
    Set ws4 = Sheets("Sheet4")
    Dim LastRow As Long
    Dim R As Long, LR As Long, n As Long

    Application.ScreenUpdating = False

    'Getting the row number of last cell
    LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row

    'Deleting any previous data from destination sheet
    ws2.Range("A2:AX10000").ClearContents

    For i = 1 To 10
        'If value in V column of the row is "" then copy the row to destination sheet
        If WS1.Cells(i, "V").Value = "" Then
            WS1.Range("E:E").Copy Destination:=ws2.Range("A1")
            WS1.Range("F:F").Copy Destination:=ws2.Range("B1")
            WS1.Range("G:G").Copy Destination:=ws2.Range("C1")
            WS1.Range("A:A").Copy Destination:=ws2.Range("E1")
            WS1.Range("O:O").Copy Destination:=ws2.Range("F1")
            WS1.Range("P:P").Copy Destination:=ws2.Range("G1")
            WS1.Range("R:R").Copy Destination:=ws2.Range("H1")
            WS1.Range("S:S").Copy Destination:=ws2.Range("I1")
            WS1.Range("Q:Q").Copy Destination:=ws2.Range("J1")
            WS1.Range("T:T").Copy Destination:=ws2.Range("K1")
            ws3.Range("E:E").Copy Destination:=ws2.Range("L1")
            ws3.Range("F:F").Copy Destination:=ws2.Range("M1")
            ws3.Range("G:G").Copy Destination:=ws2.Range("N1")
            ws3.Range("A:A").Copy Destination:=ws2.Range("O1")
            ws3.Range("S:S").Copy Destination:=ws2.Range("P1")
            ws3.Range("T:T").Copy Destination:=ws2.Range("Q1")
            ws3.Range("V:V").Copy Destination:=ws2.Range("R1")
            ws3.Range("W:W").Copy Destination:=ws2.Range("S1")
            ws3.Range("X:X").Copy Destination:=ws2.Range("T1")
            ws4.Range("F:F").Copy Destination:=ws2.Range("U1")
            ws4.Range("G:G").Copy Destination:=ws2.Range("V1")
            ws4.Range("H:H").Copy Destination:=ws2.Range("W1")
            ws4.Range("A:A").Copy Destination:=ws2.Range("X1")
            ws4.Range("L:L").Copy Destination:=ws2.Range("Y1")
            ws4.Range("M:M").Copy Destination:=ws2.Range("Z1")
            ws4.Range("N:N").Copy Destination:=ws2.Range("AA1")
            ws4.Range("O:O").Copy Destination:=ws2.Range("AB1")
            ws4.Range("P:P").Copy Destination:=ws2.Range("AC1")
            ws4.Range("Q:Q").Copy Destination:=ws2.Range("AD1")
        End If
    Next i
    LR = Cells(Rows.Count, "C").End(xlUp).Row
    Range("A2:AX" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending
    For R = 2 To LR
        'Count the number of duplicates for third row
        n = Application.CountIf(Columns(3), Cells(R, 3).Value)

        'Sum up the values for every duplicate
        Range("F" & R).Value = Evaluate("=Sum(F" & R & ":F" & R + n - 1 & ")")
        Range("G" & R).Value = Evaluate("=Sum(G" & R & ":G" & R + n - 1 & ")")
        Range("H" & R).Value = Evaluate("=Sum(H" & R & ":H" & R + n - 1 & ")")
        Range("I" & R).Value = Evaluate("=Sum(I" & R & ":I" & R + n - 1 & ")")
        Range("J" & R).Value = Evaluate("=Sum(J" & R & ":J" & R + n - 1 & ")")
        Range("K" & R).Value = Evaluate("=Sum(K" & R & ":K" & R + n - 1 & ")")
        Range("E" & R).Value = Evaluate("=Count(E" & R & ":E" & R + n - 1 & ")")
        'Go to next value in third column
        R = R + n - 1
    Next R

    On Error Resume Next
    'Remove all duplicates
    ws2.Range("$A$1:$K$7979").RemoveDuplicates Columns:=3, Header:=xlYes
    On Error GoTo 0

    'Fill out the table with values
    Columns("A:K").AutoFit
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub

The code above is for synchronizing the sheets with Distribution and filter the data from Sheet2, and I have 2 more buttons made to filter the other 2 sheets.

The code below is my attempt to align the data but it's not working correctly.

Sub LineEmUp()

    Dim i As Long, j As Long, LR As Long
    Application.ScreenUpdating = False

    LR = Range("C" & Rows.Count).End(xlUp).Row

    Columns("A:K").Sort Key1:=Range("A2"), _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    Columns("L:T").Sort Key1:=Range("L2"), _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    Columns("U:AD").Sort Key1:=Range("U2"), _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    i = 2

    Do
        If Cells(i, "C") > Cells(i, "N") And Cells(i, "C") > "" Then
            Cells(i, "A").Resize(1, 10).Insert xlShiftDown
        ElseIf Cells(i, "N") > Cells(i, "W") And Cells(i, "N") > "" Then
            Cells(i, "L").Resize(1, 10).Insert xlShiftDown
        ElseIf Cells(i, "W") > Cells(i, "C") And Cells(i, "W") > "" Then
            Cells(i, "U").Resize(1, 10).Insert xlShiftDown
        ElseIf Cells(i, "C") < Cells(i, "N") And Cells(i, "C") > "" Then
            Cells(i, "L").Resize(1, 10).Insert xlShiftDown
        ElseIf Cells(i, "N") < Cells(i, "W") And Cells(i, "N") > "" Then
            Cells(i, "U").Resize(1, 10).Insert xlShiftDown
        ElseIf Cells(i, "W") < Cells(i, "C") And Cells(i, "W") > "" Then
            Cells(i, "A").Resize(1, 10).Insert xlShiftDown
        End If
        i = i + 1
    Loop Until Cells(i, "C") = "" And Cells(i, "W") = ""

    Application.ScreenUpdating = True
End Sub

Hope I explained it properly. Thanks

Upvotes: 2

Views: 218

Answers (1)

ashleedawg
ashleedawg

Reputation: 21657

Organization (without unnecessary repetition) is always important in coding, and especially key when troubleshooting. For example, your 29 copy-paste statements can be tidied up considerably - which shows some inconsistencies.

...I sorted them by source worksheet and then by source column, and grouped them together, also pasting into columns instead of single cells.

Edit:

There's a number of "weird things" going on here that require some explanation so I know whether they're designed this way intentionally.

**See my "'<<<<<<" notes below (There are some specific questions, starting with *what happens if you don't disable screen updating, and don't ignore the errors with On Error Resume Next...?

Option Explicit

Private Sub cmd_button1_Click()
    Dim WS1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Set WS1 = Sheets("Sheet2")
    Set ws2 = Sheets("Distribution")
    Set ws3 = Sheets("Sheet3")
    Set ws4 = Sheets("Sheet4")
    'Dim LastRow As Long
    Dim R As Long, LR As Long, n As Long, i As Integer

    ' <<<<< always ALLOW screen updating during troubleshooting, until your code
    ' <<<<< is functioning perfectly: It may give a clue to the problem.
    'Application.ScreenUpdating = False

    'Getting the row number of last cell  '<<<<< variable [LastRow] is not being used.
    'LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row

    'Deleting any previous data from destination sheet
    'ws2.Range("A2:AX10000").ClearContents
    ws2.UsedRange.ClearContents ' <<<<<< instead of specifying a range, just clear what's used

    For i = 1 To 10
        'If value in V column of the row is "" then copy the row to destination sheet
        If WS1.Cells(i, "V").Value = "" Then
            WS1.Range("A:A").Copy Destination:=ws2.Range("E:E")  '<<< there's no pattern to what's being copied,
            WS1.Range("E:G").Copy Destination:=ws2.Range("A:C")  '<<< (and in a strange criss-cross),
            WS1.Range("O:S").Copy Destination:=ws2.Range("F:I")  '<<< are you sure nothing's being missed?
            WS1.Range("T:T").Copy Destination:=ws2.Range("K:K")

            ws3.Range("A:A").Copy Destination:=ws2.Range("O:O")
            ws3.Range("E:G").Copy Destination:=ws2.Range("L:N")
            ws3.Range("S:T").Copy Destination:=ws2.Range("P:Q")
            ws3.Range("V:X").Copy Destination:=ws2.Range("R:T")

            ws4.Range("A:A").Copy Destination:=ws2.Range("X1")
            ws4.Range("F:H").Copy Destination:=ws2.Range("U:W")
            ws4.Range("L:Q").Copy Destination:=ws2.Range("Y:AD")
        End If
    Next i
    LR = Cells(Rows.Count, "C").End(xlUp).Row
    Range("A2:AX" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending '<<<<< this could be a problem??
    For R = 2 To LR
        'Count the number of duplicates for third row
        n = Application.CountIf(Columns(3), Cells(R, 3).Value)

        'Sum up the values for every duplicate
        Range("F" & R).Value = Evaluate("=Sum(F" & R & ":F" & R + n - 1 & ")")  '<<<<<< this is a strange way to do this...,
        Range("G" & R).Value = Evaluate("=Sum(G" & R & ":G" & R + n - 1 & ")")  '<<<<<< can you explain the purpose of these lines?
        Range("H" & R).Value = Evaluate("=Sum(H" & R & ":H" & R + n - 1 & ")")  '<<<<<< why not just add the cells normally instead like this?
        Range("I" & R).Value = Evaluate("=Sum(I" & R & ":I" & R + n - 1 & ")")
        Range("J" & R).Value = Evaluate("=Sum(J" & R & ":J" & R + n - 1 & ")")
        Range("K" & R).Value = Evaluate("=Sum(K" & R & ":K" & R + n - 1 & ")")
        Range("E" & R).Value = Evaluate("=Count(E" & R & ":E" & R + n - 1 & ")")
        'Go to next value in third column
        R = R + n - 1 '<<<<<  WOAH!  don't change the value of R when it's being used inside a loop!!!
    Next R

    'On Error Resume Next   '<<<<< Errors mean something - Don't ignore them! (especially during troubleshooting)
    'Remove all duplicates
    ws2.Range("$A$1:$K$7979").RemoveDuplicates Columns:=3, Header:=xlYes '<<< this shifts cells around, might be a problem
    On Error GoTo 0

    'Fill out the table with values
    Columns("A:K").AutoFit
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub

Upvotes: 2

Related Questions