对齐行以匹配列

Question

问题

你怎么能水平在单独的列对齐值，并应用动态公式？优先感谢您的帮助或线索！下面粘贴的代码只要到达最终目的地的一半就行。但如何完成最后两个目标？

1）和，每一个范围

2）水平地对齐

样品片包含客户ID，产品和价格的范围内。左侧周一，右侧周二销售。

当前结果

期望的结果

对齐CUST ID上排A和E，与相关联的总和。 注意每条黄线如何包含用于识别的客户ID以及相关的总和。

现有VBA代码

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

如果我需要类似的东西，我可能会三思而后行什么，我想，为什么：如果原来的天名单中没有来自somehwere来了，你可以把一切都列入一个清单，并使一些枢轴...

但。这里的一些想法，与阵列再次玩，很可能有工作要做，但是这是否帮助：

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

我认为解决的办法是模拟SQL全外连接，通过VBA。我会开始窃取它。应该是一个有趣的个人挑战。一旦找到最终解决方案，我会尝试更新此答案。

我遵循的方向是here。