重新格式化&连接Excel电子表格数据

时间:2012-02-07 16:52:35

标签: excel vba

我有一组数据格式如下:

-----   -----         -----                    -----        -----         -----  -----                            -----   -----
| A |   | B |         | C |                    | D |        | E |         | F |  | G |                            | H |   | I |
|---------------------------------------------------------------------------------------------------------------------------------------|
| SPC   | Department  | Sub Department         | Brand      | Colour Name | Size | Description                    | Price | Carton Size |
|---------------------------------------------------------------------------------------------------------------------------------------|
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | White       | S    | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | White       | M    | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | White       | L    | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | White       | XL   | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | White       | 2XL  | Kustom Kit Workwear Pique Polo | 4.75  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | Red         | S    | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | Red         | M    | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | Red         | L    | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | Red         | XL   | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | Red         | 2XL  | Kustom Kit Workwear Pique Polo | 4.75  | 40          |
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | Red         | 3XL  | Kustom Kit Workwear Pique Polo | 4.75  | 40          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue   | 30"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue   | 32"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue   | 34"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue   | 36"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue   | 38"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue   | 40"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue   | 42"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Lichen      | 30"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Lichen      | 32"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Lichen      | 34"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Lichen      | 36"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Lichen      | 38"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Lichen      | 40"  | Regatta Action Shorts          | 9.5   | 24          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Lichen      | 42"  | Regatta Action Shorts          | 9.5   | 24          |
|---------------------------------------------------------------------------------------------------------------------------------------|

我希望它的格式如下:

|-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------|
| SPC   | Department  | Sub Department         | Brand      | Colour Names        | Sizes                              | Description                    | Price | Carton Size |
|-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------|
| KK400 | Polo Shirts | Mens Short Sleeve Polo | Kustom Kit | White, Red          | S, M, L, XL, 2XL, 3XL              | Kustom Kit Workwear Pique Polo | 4.25  | 40          |
| J172S | Workwear    | Mens Workwear          | Regatta    | Navy Blue, Lichen   | 30", 32", 34", 36", 38", 40", 42"  | Regatta Action Shorts          | 9.5   | 24          |
|-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------|

正如您所看到的,我需要连接颜色和大小。即使上面的马球在3XL白色中不可用,我仍然需要将3XL包含在决赛桌中。我也想要两个价格中的较低者。

每个SPC只能有一个产品或数百个产品。每个人都需要拥有自己的所有可用选项。

我很确定这可以使用VBA来完成,我在1996-98期间非常简短地学到了一些并在1999年忘记了。我希望有人可以提供帮助!

1 个答案:

答案 0 :(得分:1)

这是一种快速的方法。

将以下代码复制到包含数据的工作簿中的新模块中并运行createSummary

代码假设您的数据位于第一个工作表上,而SPC列是A列。我还将变量创建为公共,因此我不必将它们传递给copyToSummary

Option Explicit

Public Enum ColumnOffsets
   Dept = 1
   SubDept = 2
   Brand = 3
   ColourName = 4
   Size = 5
   Desc = 6
   Price = 7
   CartonSz = 8
End Enum

Public rDetail As Range, rSum As Range
Public sColourNames As String, sSizes As String, dLowPrice As Double

Public Sub createSummary()
' Creates a summary worksheet in this workbook.
   Dim sht As Worksheet

   'Application.ScreenUpdating = False ' uncomment to make the macro run faster

   ' assumes the detail data is on the first worksheet with the header starting at A1
   Set rDetail = ThisWorkbook.Sheets(1).Range("A1")
   Set sht = ThisWorkbook.Sheets.Add(after:=rDetail.Parent)
   sht.Name = "Summary"
   Set rSum = sht.Range("A1")

   ' sort detail to make sure all rows with the same SPC are next to each other
   Range(rDetail, rDetail.SpecialCells(xlCellTypeLastCell)).Sort rDetail, Header:=xlYes

   ' copy header
   Range(rDetail, rDetail.End(xlToRight)).Copy
   rSum.PasteSpecial xlPasteAll
   Application.CutCopyMode = False

   ' move down to first data row
   Set rSum = rSum.Offset(1)
   Set rDetail = rDetail.Offset(1)

   ' loop thru data
   Do While rDetail <> ""

      ' summarise detail
      sColourNames = Append(rDetail.Offset(0, ColourName), sColourNames)
      sSizes = Append(rDetail.Offset(0, Size), sSizes)
      If dLowPrice = 0 Or rDetail.Offset(0, Price) < dLowPrice Then
         dLowPrice = rDetail.Offset(0, Price)
      End If

      ' add to sumary worksheet
      If rDetail <> rDetail.Offset(1) Then
         copyToSummary

         ' if screen updating is turned off, refersh the screen occasionally so Excel doesn' look like it is locked up.
         ' uncomment the below code to refresh the screen every 5 rows on the summary worksheet.
'         If rSum.Row Mod 5 = 0 Then
'            Application.ScreenUpdating = True
            DoEvents
'            Application.ScreenUpdating = False
'         End If

         ' reset summary variables
         sColourNames = ""
         sSizes = ""
         dLowPrice = 0
      End If

      Set rDetail = rDetail.Offset(1)

   Loop

   ' auto-fit summary page columns
   Range(rSum, rSum.End(xlToRight).End(xlUp)).Columns.AutoFit

   Application.ScreenUpdating = True

   MsgBox "Done."

End Sub

Private Function Append(ByVal sAppendThis As String, ByVal sToSummary As String) As String
' appends given value if it isn't already in summary.
' Note: The '|' are added to prevent "Blue" from matching to "Navy Blue". They are removed in copyToSummary.
   sAppendThis = "|" & Trim(sAppendThis) & "|"
   If Len(sToSummary) = 0 Then
      sToSummary = sAppendThis
   Else
      If InStr(LCase(sToSummary), LCase(sAppendThis)) = 0 Then
         sToSummary = sToSummary & ", " & sAppendThis
      End If
   End If
   Append = sToSummary
End Function

Private Sub copyToSummary()
' copies summed detail of current spc to summary sheet
   rSum.Activate
   rSum = rDetail
   rSum.Offset(0, Dept) = rDetail.Offset(0, Dept)
   rSum.Offset(0, SubDept) = rDetail.Offset(0, SubDept)
   rSum.Offset(0, Brand) = rDetail.Offset(0, Brand)
   rSum.Offset(0, ColourName) = Replace(sColourNames, "|", "")
   rSum.Offset(0, Size) = Replace(sSizes, "|", "")
   rSum.Offset(0, Desc) = rDetail.Offset(0, Desc)
   rSum.Offset(0, Price) = dLowPrice
   rSum.Offset(0, CartonSz) = rDetail.Offset(0, CartonSz)
   Set rSum = rSum.Offset(1)
End Sub