Align Reihen Spalte passen

Question

Problem

Wie kann man horizontal Werte in separaten Spalten ausrichten, und eine dynamische Formel anwenden? Präventiv danke für jede Hilfe oder Hinweise! Der unten eingefügte Code funktioniert insofern, als er die Hälfte des Endziels erreicht. Aber wie werden die letzten beiden Ziele erreicht?

1) Summe jeder Bereich

2) ausrichten, um die Bereiche horizontal

Ein Probenblech, das Kunden-ID, Position und Preise. Verkauf von Montag auf der linken Seite, Dienstag auf der rechten Seite.

Aktuelle Ergebnisse

gewünschten Ergebnisse

Align cust id auf Reihen A und E, mit einer zugehörigen Summe. Beachten Sie, wie jede gelbe Zeile die Kundennummer für die Identifizierung sowie die zugehörige Summe enthält.

Bestehende VBA-Code

Sub AlignAndMatch() 
    'backup sheet 
    ActiveSheet.Copy after:=Sheets(Sheets.Count) 

    'Insert rows where current cell <> cell above 
    Dim i, totalrows As Integer 
    Dim strRange As String 
    Dim strRange2 As String 

    '---------------------------------------- 
    'Monday sort table 
    Range("A2:C65536").Select 
    Selection.Sort Key1:=Range("A2:C65536"), Order1:=xlAscending, Header:=xlGuess, _ 
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
    DataOption1:=xlSortNormal 

    'Monday insert loop 
    totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row 
    i = 0 

    Do While i <= totalrows 
     i = i + 1 
     strRange = "A" & i 
     strRange2 = "A" & i + 1 
     If Range(strRange).Text <> Range(strRange2).Text Then 
      Range(Cells(i + 1, 1), Cells(i + 2, 3)).Insert xlDown 'think cells ~A1:C2 insert 
      totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row 
      i = i + 2 'for insert 2 rows 
     End If 
    Loop 

    'Monday footer row loop 
    totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row 
    i = 0 

    Do While i <= totalrows 
     i = i + 1 
     If IsEmpty(Range("A" & i).Value) And Not IsEmpty(Range("A" & i + 1).Value) Then 
      Range("A" & i).Value = Range("A" & i + 1).Value 
      Range("B" & i).Value = "Sum" 
     End If 
    Loop 

    '---------------------------------------- 
    'Tuesday sort table 
    Range("E2:G65536").Select 
    Selection.Sort Key1:=Range("E2:G65536"), Order1:=xlAscending, Header:=xlGuess, _ 
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
    DataOption1:=xlSortNormal 

    'Tuesday insert loop 
    totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row 
    i = 0 

    Do While i <= totalrows 
     i = i + 1 
     strRange = "E" & i 
     strRange2 = "E" & i + 1 
     If Range(strRange).Text <> Range(strRange2).Text Then 
      Range(Cells(i + 1, 5), Cells(i + 2, 7)).Insert xlDown 'think cells ~A1:C2 insert 
      totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row 
      i = i + 2 'for insert 2 rows 
     End If 
    Loop 

    'Tuesday footer row loop 
    totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row 
    i = 0 

    Do While i <= totalrows 
     i = i + 1 
     If IsEmpty(Range("E" & i).Value) And Not IsEmpty(Range("E" & i + 1).Value) Then 
      Range("E" & i).Value = Range("E" & i + 1).Value 
      Range("F" & i).Value = "Sum" 
     End If 
    Loop 
End Sub 

Answer 1

Wenn ich so etwas brauchte ich vielleicht denken, zweimal, was ich will und warum: wenn die ursprünglichen Tag Listen von somehwere nicht kommen, könnten Sie setzen alles in eine Liste und einige Pivots machen ...

Aber. Hier ist eine Idee, wieder mit den Arrays zu spielen, und es ist wahrscheinlich arbeiten zu tun, aber tut diese Hilfe:

Option Base 1 

Sub ReLists() 

Dim ListSheet As Worksheet 
Dim DayCorners() As Range 
Dim Day() 
Dim Days As Integer 
Dim CustIDs() 
Dim CustomerRow()   'for placement in the final list 
Dim DayList() 
Dim MaxCustIDs As Integer 
Dim NewCustID As Boolean 

Days = 2 
MaxCustIDs = 5 

ReDim DayCorners(Days) 
ReDim Day(Days) 
ReDim CustomerRow(MaxCustIDs + 2) 
CustomerRow(1) = 0 

ReDim CustIDs(MaxCustIDs) 
ReDim DayItems(1, 1) 

Set ListSheet = Worksheets("Sheet1") 
Set DayCorners(1) = ListSheet.Range("A2") 
Set DayCorners(2) = ListSheet.Range("E2") 

For d = 1 To Days 

    With ListSheet.Sort 
     .SortFields.Clear 
     .SortFields.Add Key:=DayCorners(d) 
     .SetRange Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2)) 
     .Header = xlNo 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .Apply 
    End With 

    Day(d) = Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2)) 

    If UBound(Day(d), 1) > UBound(DayItems, 2) Then 
     ReDim DayItems(Days, UBound(Day(d))) 
    End If 

Next d 

CustIDCount = 0 

For d = 1 To Days 

    For r = 1 To UBound(Day(d), 1) 

    NewCustID = True 

     For u = 1 To UBound(CustIDs) 
      If CustIDs(u) = Day(d)(r, 1) Then NewCustID = False 
     Next u 
     If NewCustID Then 
      CustIDCount = CustIDCount + 1 
      CustIDs(CustIDCount) = Day(d)(r, 1) 

     End If 
    Next r 

Next d 

    With Worksheets.Add(After:=Worksheets(ListSheet.Index)) 
     Set DayCorners(1) = .Range("A2") 
     Set DayCorners(2) = .Range("E2") 
    End With 

ReDim DayList(Days, CustIDCount, 100, 3) 

For d = 1 To Days 

    For c = 1 To CustIDCount 

    rc = 1 

      For r = 1 To UBound(Day(d), 1) 

       If Day(d)(r, 1) = CustIDs(c) Then 

        DayList(d, c, rc, 1) = Day(d)(r, 1) 
        DayList(d, c, rc, 2) = Day(d)(r, 2) 
        DayList(d, c, rc, 3) = Day(d)(r, 3) 

        rc = rc + 1 

       End If 

      Next r 

     If CustomerRow(c) + rc + 2 > CustomerRow(c + 1) Then 

      CustomerRow(c + 1) = CustomerRow(c) + rc + 1 

     End If 

    Next c 

    If CustomerRow(c - 1) + rc + 2 > CustomerRow(c) Then 

      CustomerRow(c) = CustomerRow(c) + rc 

    End If 

Next d 

For d = 1 To Days 

With DayCorners(d).Offset(-1, 0).Range("A1:C1") 
    .Value = Array("cust id", "item", "Price") 
    'formatting 
End With 

    For c = 1 To CustIDCount 

    SumFormula = "=SUM(R[1]C:R[" & (CustomerRow(c + 1) - CustomerRow(c) - 1) & "]C)" 

    With DayCorners(d).Offset(CustomerRow(c), 0).Range("A1:D1") 
     If Not IsEmpty(DayList(d, c, 1, 1)) Then 
      .Value = Array(CustIDs(c), "Sum", SumFormula, "") 
     End If 
     .Interior.Color = 65535 
    End With 

      For rc = 1 To UBound(Day(d), 1) 

       If IsEmpty(DayList(d, c, rc, 1)) Then Exit For 

       DayCorners(d).Offset(CustomerRow(c) + rc, 0) = DayList(d, c, rc, 1) 
       DayCorners(d).Offset(CustomerRow(c) + rc, 1) = DayList(d, c, rc, 2) 
       DayCorners(d).Offset(CustomerRow(c) + rc, 2) = DayList(d, c, rc, 3) 

      Next rc 

    Next c 

Next d 

End Sub 

Answer 2

Ich glaube, die Lösung ist eine SQL vollständige äußere Verknüpfung, über VBA zu simulieren. Ich werde anfangen, es zu hacken. Sollte eine lustige persönliche Herausforderung sein. Ich werde versuchen, diese Antwort zu aktualisieren, sobald ich die endgültige Lösung gefunden habe.

Die Richtung, der ich folge, ist here.