Question

我在工作表中有2个动力学表

    projectId | start    | end      | employee | name | amount
    ----------------------------------------------------------
    5013-001  | 12-01-01 | 13-01-01 |  001     | bob  | 100 $
                                    |  021     | foo  | 200 $
                                    |  101     | bar  | 300 $
                                    |  111     | luc  | 300 $
    ----------------------------------------------------------
    total 5013-001                                      900 $
    ----------------------------------------------------------
    5013-002  | 12-01-01 | 13-01-01 |  001     | bob  | 150 $
                                    |  021     | foo  | 205 $
    ----------------------------------------------------------
    total 5013-002                                      355 $

    --Snip--

    projectId | expenseCode     | total
    ---------------------------------------
    5013-001   | T01 Summary      | 4504$
               | D01 Summary      |  204$
    total 5013-001                | 4708$
    ---------------------------------------
    5013-002   | T01 Summary      | 1007$
    total 5013-002                | 1007$

    --Snip--

预期结果：

    projectId | start    | end      | employee | name | amount
    ----------------------------------------------------------
    5013-001  | 12-01-01 | 13-01-01 |  001     | bob  | 100 $
                                    |  021     | foo  | 200 $
                                    |  101     | bar  | 300 $
    ----------------------------------------------------------
    total 5013-001                                      600 $
    ----------------------------------------------------------

    projectId | expenseCode     | total
    ---------------------------------------
    5013-001   | T01 Summary      | 4504$
               | D01 Summary      |  204$
    total 5013-001                | 4708$
    ---------------------------------------

    --page break--

如何继续使用projectId对两个表进行过滤，每个表都在一个页面上？（列数是固定的，但不是行！）

我猜一个宏，但我可能会更简单。

如果我确实应该使用宏，那引擎是否足够强大？我从来没有编写过excel宏，所以我很乐意接受任何提示/参考。

最后一个主观问题：你认为这个问题在〜1个工作日内是否可以解决？

Answer 1

你的个人资料说你编程所以我认为问题是你不知道VBA语法。我对你的表做了假设，但我也假设如果我的假设不正确你可以修改我的代码。

我在工作表TblSrc中创建了一份数据副本。

表1：

Source table 1

表2：

Source table 2

我复制了这些行，所以每个主表中有8个子表。代码依赖于两个主表之间的一对一匹配。我不检查两个子表匹配。对于任何实际时间而言，这都不是足够的数据，但对于，值得的是，下面的宏花了0.03秒来复制四对子表来创建：

Destination table

我通过合并单元格创建了连字符行，将第一个设置为' - 并将水平对齐设置为Fill。我通过检查列A的第一个字符是连字符来识别分隔符行。连字符前面的单引号是为了让它看起来像一个无效的负数。它不是细胞价值的一部分。

此宏不是解决此问题的最快方法，但会将子表中的任何格式从源复制到目标。

宏中有一些评论但可能还不够。我建议你用F5（运行到下一个断点）和F8（执行下一个语句）逐步执行宏。

回答问题，我会改进答案。如果您可以提供有关数据的更多信息，我可以向您展示其他方法。

警告这是21:45，我不确定明天我的互联网接入。我会尽快回答问题。

选项明确 Sub CombineTables（）

 Dim CellValue() As Variant
 Dim ColCrnt As Long
 Dim ColMax As Long
 Dim Found As Boolean
 Dim RngStgHeader1 As String
 Dim RngStgHeader2 As String
 Dim RngStgHeaderX As String
 Dim RowDestCrnt As Long
 Dim RowSrcSubTab1End As Long
 Dim RowSrcSubTab1Start As Long
 Dim RowSrcSubTab2End As Long
 Dim RowSrcSubTab2Start As Long
 Dim RowSrcTab1Crnt As Long
 Dim RowSrcTab2Crnt As Long
 Dim RowSrcTab1End As Long
 Dim RowSrcTab1Start As Long
 Dim RowSrcTab2End As Long
 Dim RowSrcTab2Start As Long
 Dim timeStart As Double

  Application.EnableEvents = False   ' Prevents any event routine being called
  Application.ScreenUpdating = False ' Screen updating causes flicker and is slow

  timeStart = Timer     ' Seconds since midnight

 ' Gather information from source worksheet
 With Worksheets("TblSrc")

   ' These statements find the last row and the last column containing a value
   RowSrcTab2End = .Cells.Find("*", .Range("A1"), xlFormulas, , _
                                                       xlByRows, xlPrevious).Row
   ColMax = .Cells.Find("*", .Range("A1"), xlFormulas, , _
                                                 xlByColumns, xlPrevious).Column

   CellValue = .Range(.Cells(1, 1), .Cells(RowSrcTab2End, ColMax)).Value
   ' CellValue is now a 2D array containing every value from the used range.
   ' The first dimension will be for the rows and the second for the columns.
   ' The lower bound of each dimension will be 1.  The upper bounds will be
   ' RowSrcTab2End and ColMax.  Having the rows as the first dimension is
   ' unusual is the nature of arrays loaded from or to a worksheet.

   ' I did not have to copy the data to an array.  I could have done so
   ' because I believe searching for sub tables will be sufficiently faster
   ' to make this a sensible choice.

 End With

 ' Find the start of the main tables.
 For RowSrcTab1Crnt = 1 To RowSrcTab2End
   If CellValue(RowSrcTab1Crnt, 1) = "projectId" And _
      CellValue(RowSrcTab1Crnt, 2) = "start" Then
      RowSrcTab1Start = RowSrcTab1Crnt
      Exit For
   End If
 Next

 For RowSrcTab2Crnt = RowSrcTab1Crnt + 1 To RowSrcTab2End
   If CellValue(RowSrcTab2Crnt, 1) = "projectId" And _
      CellValue(RowSrcTab2Crnt, 2) = "expenseCode" Then
      RowSrcTab2Start = RowSrcTab2Crnt
      Exit For
   End If
 Next

 RowSrcTab1End = RowSrcTab2Start - 1

 ' Output values found to the Immediate window as a check
 Debug.Print "Table 1 rows: " & RowSrcTab1Start & " - " & RowSrcTab1End
 Debug.Print "Table 2 rows: " & RowSrcTab2Start & " - " & RowSrcTab2End

 With Worksheets("TblDest")
   ' Clear current contents of destination sheet
   .Cells.EntireRow.Delete
 End With

 ' Build range strings for table headers because
 ' they are needed for every projectId
 RngStgHeader1 = "A" & RowSrcTab1Start & ":" & _
                                 ColNumToCode(ColMax) & RowSrcTab1Start
 RngStgHeader2 = "A" & RowSrcTab2Start & ":" & _
                                 ColNumToCode(ColMax) & RowSrcTab2Start

 RowSrcTab1Crnt = RowSrcTab1Start + 1  ' \ Start point for search
 RowSrcTab2Crnt = RowSrcTab2Start + 1  ' / for first sub tables
 RowDestCrnt = 1  ' Position for first output sub tables

 Do While True

   ' Search for start of next sub table 1
   Found = False
   Do While RowSrcTab1Crnt < RowSrcTab2Start
     If CellValue(RowSrcTab1Crnt, 1) <> "" And _
        Left(CellValue(RowSrcTab1Crnt, 1), 1) <> "-" Then
       ' Assume next table 1 row with column A not empty and not starting
       ' with a hyphen is the start of next table 1 sub table
       Found = True
       RowSrcSubTab1Start = RowSrcTab1Crnt
       RowSrcTab1Crnt = RowSrcTab1Crnt + 1  ' Prepare for search for end
       Exit Do
     End If
     RowSrcTab1Crnt = RowSrcTab1Crnt + 1
   Loop
   If Not Found Then
     ' No next sub table 1 found.  All done.
     Exit Do
   End If

   ' Search for end of this sub table 1
   Found = False
   Do While RowSrcTab1Crnt < RowSrcTab2Start
     If LCase(Left(CellValue(RowSrcTab1Crnt, 1), 5)) = "total" Then
       Found = True
       RowSrcSubTab1End = RowSrcTab1Crnt
       RowSrcTab1Crnt = RowSrcTab1Crnt + 1  ' Prepare for next loop
       Exit Do
     End If
     RowSrcTab1Crnt = RowSrcTab1Crnt + 1
   Loop
   If Not Found Then
     ' End of table not found.  Either data error or program error
     Debug.Assert False     ' Interpreter will stop here to allow
                            ' examination of variables
     Exit Do
   End If

   ' Search for start of next sub table 2
   Found = False
   Do While RowSrcTab2Crnt < RowSrcTab2End
     If CellValue(RowSrcTab2Crnt, 1) <> "" And _
        Left(CellValue(RowSrcTab2Crnt, 1), 1) <> "-" Then
       ' Assume next table 2 row with column A not empty and not starting
       ' with a hyphen is the start of next table 2 sub table
       Found = True
       RowSrcSubTab2Start = RowSrcTab2Crnt
       RowSrcTab2Crnt = RowSrcTab2Crnt + 1  ' Prepare for search for end
       Exit Do
     End If
     RowSrcTab2Crnt = RowSrcTab2Crnt + 1
   Loop
   If Not Found Then
     ' No next sub table 2 found.  Have table 1 so have data or program error.
     Debug.Assert False     ' Interpreter will stop here to allow
                            ' examination of variables
     Exit Do
   End If

   ' Search for end of this sub table 2
   Found = False
   Do While RowSrcTab2Crnt < RowSrcTab2End
     If LCase(Left(CellValue(RowSrcTab2Crnt, 1), 5)) = "total" Then
       Found = True
       RowSrcSubTab2End = RowSrcTab2Crnt
       RowSrcTab2Crnt = RowSrcTab2Crnt + 1  ' Prepare for next loop
       Exit Do
     End If
     RowSrcTab2Crnt = RowSrcTab2Crnt + 1
   Loop
   If Not Found Then
     ' End of table not found.  Either data error or program error
     Debug.Assert False     ' Interpreter will stop here to allow
                            ' examination of variables
     Exit Do
   End If

   ' Have start and end of next sub tables.

   ' Copy header row for table 1
   Worksheets("TblSrc").Range(RngStgHeader1).Copy _
                     Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
   RowDestCrnt = RowDestCrnt + 1
   ' Copy sub table 1 plus rows before and after which should be dividing rows
   RngStgHeaderX = "A" & RowSrcSubTab1Start - 1 & ":" & _
                                   ColNumToCode(ColMax) & RowSrcSubTab1End + 1
   Worksheets("TblSrc").Range(RngStgHeaderX).Copy _
                      Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
   RowDestCrnt = RowDestCrnt + RowSrcSubTab1End - RowSrcSubTab1Start + 4
   ' Copy header row for table 2
   Worksheets("TblSrc").Range(RngStgHeader2).Copy _
                     Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
   RowDestCrnt = RowDestCrnt + 1
   ' Copy sub table 2 plus rows before and after which should be dividing rows
   RngStgHeaderX = "A" & RowSrcSubTab2Start - 1 & ":" & _
                                   ColNumToCode(ColMax) & RowSrcSubTab2End + 1
   Worksheets("TblSrc").Range(RngStgHeaderX).Copy _
                      Destination:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
   RowDestCrnt = RowDestCrnt + RowSrcSubTab2End - RowSrcSubTab2Start + 3

   ' Warning there is a limit of 1026 on the number of horizontal page breaks
   Worksheets("TblDest").HPageBreaks.Add _
                           Before:=Worksheets("TblDest").Cells(RowDestCrnt, 1)
 Loop

 Debug.Print Timer - timeStart

 Application.EnableEvents = True
 Application.ScreenUpdating = True


End Sub

Function ColNumToCode(ByVal ColNum As Long) As String

  ' Convert column number (such as 1, 2, 27, etc.) to
  ' column code (such as A, B, AA, etc.)

  Dim Code As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.
  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    Code = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      Code = Chr(65 + PartNum) & Code
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = Code

End Function

如何根据id复制excel中的部分动态表？

1 个答案: