整合和传输多张表中的数据

时间:2015-03-30 21:10:52

标签: excel vba excel-vba

我被困在将数据传输到摘要表中。我有两张纸,想把它总结成第三张。

                                Sheet A

       A             B                    C                    D
1                  Apple                Orange               Peach
2   Period        Apple_Price       Orange_price            peach_price
3      1            5                     5                    3                  
4      2            6                     4                    9 
5      3            7                                          7

                                 Sheet B

       A             B                    C                    D
1                  Apple                Orange                Peach
2   Period        Apple_weight       Orange_Weight            peach_Weight
3      1            2.1                     2.5                    3.1                  
4      2            2.1                     1.1                    2.1 
5      3            3.1                                            2.5




                Summary sheet or sheet c (expected)

       A             B                    C                    D
1                Period                  Price             Weight            
2   Apple           1                      5                  2.1
3                   2                      6                  2.1 
4                   3                      7                  3.1
5   Orange          1                      5                  2.5
6                   2                      4                  1.1
7   Peach           1                      3                  3.1
8                   2                      9                  2.1
9                   3                      7                  2.5

我开始编写的代码有点像

For Each Name In Range("B1:D1")
' To copy each name in to first column of summary
Name.Cells.value.copy  Worksheets("Summary").Offset(2,0)  
' Now to copy a column from each sheet in front of corresponding name
Worksheets("SheetA").Range(Name & lastrow).Copy
Worksheets("summary").Range("a65536").End(xlUP).Offset(2,1)
'Now copy Periods and prices 
Worksheets("SheetA").Range(Name & lastrow).Copy
Worksheets("summary").Range("a65536").End(xlUP).Offset(2,2) 
'Now copy weights
Worksheets("SheetB").Range(Name & lastrow).Copy
Worksheets("summary").Range("a65536").End(xlUP).Offset(2,3) 
Next

不幸的是我无法完成这项工作。我认为偏移存在一些问题。

1 个答案:

答案 0 :(得分:1)

首先让我们看一下您现有的代码。


For Each Name In Range("B1:D1")

这假设有三个果实。添加第四个时,您必须在添加第五个时再次更新此代码。决定哪些水果有意义的人,维持宏观吗?如果没有,每次他们添加水果时,都必须要求更新宏。

确定未来可能允许的更改是平衡:

  • 几乎没有努力允许额外的水果或额外的时间段,在大多数情况下这是一个非常可能的变化,所以我通常允许它。
  • 目前,您有价格和重量作为有趣的属性。允许新的属性可能会很棘手;我通常不会打扰。
  • 果实的序列是否相同?周期是否在同一序列中?允许这些变化比允许额外的水果或时期更麻烦,所以我应该允许吗?在早期的生活中,我负责许多类似的任务。工作表格式经常被改变,我无法理解。如果我只是假设工作表是我期望的格式,我可以创建逼真但错误的摘要,并且错误可能在一段时间内无法识别。至少,我总是对我预期的格式的工作表进行检查。

由于我对您的申请一无所知,我不是要求您同意我对准备的更改的评估。我请你考虑一下这个问题。您未检查的更改可能会导致损坏的摘要或崩溃的宏。这有多重要?您已检查但未处理的更改意味着在更新宏之前无法运行该宏。这有多重要?


Worksheets("summary").Range("a65536").End(xlUP).Offset(2,1)

在Excel 2007之前,工作表有65536行,因此单元格A65536位于列A的底部。自2007年以来编码的任何人都建议使用Cells(Rows.Count, 1)而不是Range("a65536"),因为它指定了底部当前版本的Excel的A列,无论它是什么。

我不喜欢Offset因为您必须执行心算来确定正在处理哪个单元格。如果句点数不总是正好为3,则必须对偏移行执行算术运算。也就是说:Offset(2, 1)必须由Offset(2+Period-1, 1)之类的内容替换。此外,您已从A列的底部开始,在执行偏移之前向上移动到列中的第一个单元格。

如果您的代码每天要执行数百万次,那么在运行时间内缩短一毫秒可能是合适的,但这是否合适?你编写这段代码需要多长时间(这无论如何都不起作用)以及代码的未来维护者要花多长时间才能理解你在做什么?我的建议是使代码简单易用,除非有一些压倒性的理由使它复杂且难以编写。

我的代码包含了节省时间的小技巧。这些都很容易实现,可以自动化。如果您需要10或20秒的时间来输入一个声明,以便为用户节省一小段时间,那么公司可以在几个月内获得投资回报(您的编码时间<用户的等待时间) 。此外,其中一些技巧使未来的维护更容易。对于必须在6或12个月内更新此宏的人来说,总是让生活更轻松,因为那个人可能就是你。


请不要使用“SheetA”或“SheetB”之类的名称。 “价格”和“重量”等名称会立即告诉您工作表的用途。有意义的名字变得如此简单。


我认为这是足够的批评。

仔细阅读此代码。有很多评论解释我正在尝试什么,但很少有评论解释每个声明的作用,所以如果你不知道也无法猜测你将不得不查看这些。使用F8逐个语句逐步执行宏语句。你了解每个陈述的作用以及我为什么要这样做吗?如果有必要,请回答问题,但是你越能自己解决问题,你就越快发展自己的技能。

Option Explicit

' Constants make maintenance so much easier:
'  * You code is full of meaningful names rather than numbers whos purpose
'    must be looked up.
'  * If columns are rearranged or an extra heading line added to one of the
'    worksheets, one change here and the problem is fixed.
Const ColPWPeriod As Long = 1
Const ColPWDataFirst As Long = 2
Const ColSummaryFruit As Long = 1
Const ColSummaryPeriod As Long = 2
Const ColSummaryPrice As Long = 3
Const ColSummaryWeight As Long = 4
Const ColSummaryLast As Long = 4
Const RowPWFruit As Long = 1
Const RowPWDataFirst As Long = 3
Sub CombineABIntoS()

  Dim ColPriceLast As Long
  Dim ColPWCrnt As Long
  Dim ColWeightLast As Long
  Dim FruitCrnt As String
  Dim RowPriceLast As Long
  Dim RowPWCrnt As Long
  Dim RowSummaryCrnt As Long
  Dim RowWeightLast As Long
  Dim WshtPrice As Worksheet
  Dim WshtWeight As Worksheet
  Dim WshtSummary As Worksheet

  ' Updating the screen for each change can be very time consuming.
  Application.ScreenUpdating = False

  ' * It takes the interpreter a noticable fraction of a second to process
  '   Worksheets("Xxxxx") because it has to look "Xxxxx" up in its collection
  '   of worksheet names. These cause these look ups to be performed once and
  '   the result stored. With all the switching between worksheets this can
  '   reduce duration noticably.
  ' * If the names of the worksheets change, only these statements will need
  '   amendment to fully update the macro.
  ' * These are not your names.  If you do not accept my advice, change to
  '   your worksheet names
  Set WshtPrice = Worksheets("Price")
  Set WshtWeight = Worksheets("Weight")
  Set WshtSummary = Worksheets("Summary")

  ' For price worksheet, find last row with a period and last column with a fruit
  With WshtPrice
    ColPriceLast = .Cells(1, Columns.Count).End(xlToLeft).Column
    RowPriceLast = .Cells(Rows.Count, ColPWPeriod).End(xlUp).Row
  End With

  ' For weight worksheet, find last row with a period and last column with a fruit
  With WshtWeight
    ColWeightLast = .Cells(1, Columns.Count).End(xlToLeft).Column
    RowWeightLast = .Cells(Rows.Count, ColPWPeriod).End(xlUp).Row
  End With

  ' Check worksheets match.
  ' Check same number of fruits
  If ColPriceLast <> ColWeightLast Then
    Call MsgBox("Worksheet " & WshtPrice.Name & " has " & _
                ColPriceLast - ColPWDataFirst + 1 & _
                " fruit while worksheet " & WshtWeight.Name & " has " & _
                ColWeightLast - ColPWDataFirst + 1 & _
                ". Sorry I cannot handle this situation", _
                vbOKOnly, "Combine Price and Weight worksheets")
    Exit Sub
  End If
  ' Check same number of periods
  If RowPriceLast <> RowWeightLast Then
    Call MsgBox("Worksheet " & WshtPrice.Name & " has " & _
                RowPriceLast - RowPWDataFirst + 1 & _
                " periods while worksheet " & WshtWeight.Name & " has " & _
                RowWeightLast - RowPWDataFirst + 1 & _
                ". Sorry I cannot handle this situation", vbOKOnly, _
                "Combine Price and Weight worksheets")
    Exit Sub
  End If
  ' Check same fruits in same sequence.
  ' Note: have already checked ColPriceLast = ColWeightLast
  For ColPWCrnt = ColPWDataFirst To ColPriceLast
    If WshtPrice.Cells(RowPWFruit, ColPWCrnt).Value <> _
       WshtWeight.Cells(RowPWFruit, ColPWCrnt).Value Then
      Call MsgBox("Cell " & ColNumToCode(ColPWCrnt) & RowPWFruit & _
                  " of worksheet " & WshtPrice.Name & " = """ & _
                  WshtPrice.Cells(RowPWFruit, ColPWCrnt).Value & _
                  """ while the same cell in worksheet " & _
                  WshtWeight.Name & " = """ & _
                  WshtWeight.Cells(RowPWFruit, ColPWCrnt).Value & _
                  """. Sorry I cannot handle this situation", vbOKOnly, _
                  "Combine Price and Weight worksheets")
      Exit Sub
    End If
  Next
  ' Check same periods in same sequence.
  ' Note: have already checked RowPriceLast = RowWeightLast
  For RowPWCrnt = RowPWDataFirst To RowPriceLast
    If WshtPrice.Cells(RowPWCrnt, ColPWPeriod).Value <> _
       WshtWeight.Cells(RowPWCrnt, ColPWPeriod).Value Then
      Call MsgBox("Cell " & ColNumToCode(ColPWPeriod) & RowPWCrnt & _
                  " of worksheet " & WshtPrice.Name & " = """ & _
                  WshtPrice.Cells(RowPWCrnt, ColPWPeriod).Value & _
                  """ while the same cell in worksheet " & _
                  WshtWeight.Name & " = """ & _
                  WshtWeight.Cells(RowPWCrnt, ColPWPeriod).Value & _
                  """. Sorry I cannot handle this situation", vbOKOnly, _
                  "Combine Price and Weight worksheets")
      Exit Sub
    End If
  Next

  ' Formats of two worksheets match

  ' For summary worksheet, clear existing contents, create header row
  ' and initialise row counter
  With WshtSummary
    .Cells.EntireRow.Delete  ' Clear any existing contents
    .Cells(1, ColSummaryFruit).Value = "Fruit"
    .Cells(1, ColSummaryPeriod).Value = "Period"
    .Cells(1, ColSummaryPrice).Value = "Price"
    .Cells(1, ColSummaryWeight).Value = "Weight"
    .Range(.Cells(1, 1), .Cells(1, ColSummaryLast)).Font.Bold = True
    RowSummaryCrnt = 2
  End With

  For ColPWCrnt = ColPWDataFirst To ColPriceLast
    ' Can copy across fruit from either worksheet since checked to match
    WshtSummary.Cells(RowSummaryCrnt, ColSummaryFruit).Value = _
                                  WshtPrice.Cells(RowPWFruit, ColPWCrnt).Value
    For RowPWCrnt = RowPWDataFirst To RowPriceLast
      If WshtPrice.Cells(RowPWCrnt, ColPWCrnt).Value <> "" Or _
         WshtWeight.Cells(RowPWCrnt, ColPWCrnt).Value <> "" Then
        ' There is either a price or a weight or both for this period and fruit
        ' Can copy across period  from either worksheet since checked to match
        WshtSummary.Cells(RowSummaryCrnt, ColSummaryPeriod).Value = _
                                  WshtPrice.Cells(RowPWCrnt, ColPWPeriod).Value
        ' Copy across price and weight
        WshtSummary.Cells(RowSummaryCrnt, ColSummaryPrice).Value = _
                                  WshtPrice.Cells(RowPWCrnt, ColPWCrnt).Value
        WshtSummary.Cells(RowSummaryCrnt, ColSummaryWeight).Value = _
                                  WshtWeight.Cells(RowPWCrnt, ColPWCrnt).Value
        ' Step summart row ready fro next period or fruit
        RowSummaryCrnt = RowSummaryCrnt + 1
      End If
    Next RowPWCrnt
  Next ColPWCrnt

End Sub
Function ColNumToCode(ByVal ColNum As Long) As String

  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