VBA_Excel01_自動合併生成報表

範例結果

０、開始

一、宣告變數

Sub 報表生成()

'S1 宣告變數
  Dim wht As Worksheet, rng As Range
  Dim n As Long, k As Long

End Sub

二、複製工作表

'S2 複製目前工作表 並更名
  ActiveSheet.Copy after:=ActiveSheet
  ActiveSheet.Name = "結果"
  Set wht = ActiveSheet

三、進行數據排序

A. 課程步驟

A-1 錄製巨集情形

Sub 錄1_排序()

' 錄1_排序 巨集

    ActiveWorkbook.Worksheets("結果").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("結果").Sort.SortFields.Add2 Key:=Range("C2:C187"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("結果").Sort.SortFields.Add2 Key:=Range("D2:D187"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("結果").Sort.SortFields.Add2 Key:=Range("B2:B187"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("結果").Sort
        .SetRange Range("A1:F187")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

A-2 修改錄製步驟

'S3 進行數據排序 依 經銷商>商品為順序
    With wht.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A:F")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

四、找出最後一列的列號

'S4 找出報表中的最後一列列號
  n = wht.Cells(Rows.Count, 1).End(xlUp).Row
  MsgBox "Rows.Count：" & Rows.Count & Chr(10) & _
          "n值,報表最後列號：" & n

A. 範圍 表示方法

B. 選取範圍 列舉

五、各項計算

'S5 各項計算
  Range("G1:J1") = Array("產品" & Chr(10) & "筆數", "產品" & Chr(10) & "總金額", "經銷商" & Chr(10) & "筆數", "經銷商" & Chr(10) & "總金額")
  
  For k = 2 To n
  
    '經銷商C  筆數 及 金額
      'Range("I" & k) = Application.WorksheetFunction.CountIf(Range("C:C"), Range("C" & k))
      Cells(k, "I") = Application.WorksheetFunction.CountIf(Columns("C"), Cells(k, "C"))
      Cells(k, "J") = Application.WorksheetFunction.SumIf(Columns("C"), Cells(k, 3), Columns("F"))
    
    '同經銷商C 同產品D 之下  數量 及 金額
      Cells(k, "G") = Application.WorksheetFunction.CountIfs(Columns("C"), Cells(k, "C"), Columns("D"), Cells(k, "D"))
      Cells(k, "H") = Application.WorksheetFunction.SumIfs(Columns("F"), Columns("C"), Cells(k, "C"), Columns("D"), Cells(k, "D"))
    
    '序號A 加入
      Cells(k, 1) = k - 1
  Next

六、合併儲存格

A. 課程步驟

A-1 依需求 進行合併儲存格

'S6 同經銷商 及 同經銷商 同產品，進行合併儲存格

  For k = n To 2 Step -1
  
    '同經銷商 同產品
      If Range("C" & k) & Range("D" & k) = Range("C" & k - 1) & Range("D" & k - 1) Then
        Range("D" & k - 1).Resize(2, 1).Merge
        Range("G" & k - 1).Resize(2, 1).Merge
        Range("H" & k - 1).Resize(2, 1).Merge
      End If
      
    '同經銷商
      If Range("C" & k) = Range("C" & k - 1) Then
        Range("C" & k - 1).Resize(2, 1).Merge
        Range("I" & k - 1).Resize(2, 1).Merge
        Range("J" & k - 1).Resize(2, 1).Merge
      End If
  Next

A-2 設定是否顯示確認訊息

Sub 報表生成()
  Application.DisplayAlerts = False

'S1 宣告變數
  Dim wht As Worksheet, rng As Range
  Dim n As Long, k As Long
...  
...

  Application.DisplayAlerts = True

End Sub

七、儲存格美化

A. 課程步驟

A-1 錄製巨集情形

Sub 錄2_美化格式()

' 錄2_美化格式 巨集


  'S7-1 全部表格 > 儲存格水平置中 > 加藍色框線 > 行高20
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -4165632
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -4165632
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = -4165632
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -4165632
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = -4165632
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Color = -4165632
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.RowHeight = 20
    
    
  'S7-2 交易日期 B 欄 ,設定西元日期格式 yyyy/mm/dd
    Columns("B:B").Select
    Selection.NumberFormatLocal = "yyyy/mm/dd"
    
    
  'S7-3 金額 F、H、J 欄，設定格式為 #,##0 及儲存格水平靠右對齊
    Range("F:F,H:H,J:J").Select
    Range("J1").Activate
    Selection.NumberFormatLocal = "#,##0"
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With

  
  'S7-4 表格標題，將 序號 A1 格式複製到 A1~J1 > 設定自動換行
    Range("A1").Select
    Selection.Copy
    Range("A1:J1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Rows.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
  'S8 設定儲存格最後停留位置
    Range("A1").Select
End Sub

A-2 修改錄製步驟

'S7 格式美化

  'S7-1 全部表格 > 儲存格水平置中 > 加藍色框線 > 行高20
    ActiveCell.CurrentRegion.Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Borders.Color = -4165632
        .Borders.Weight = xlThin
        .RowHeight = 20
    End With

  'S7-2 交易日期 B 欄 ,設定西元日期格式 yyyy/mm/dd
    Columns("B:B").Select
    Selection.NumberFormatLocal = "yyyy/mm/dd"
    
  'S7-3 金額 F、H、J 欄，設定格式為 #,##0 及儲存格水平靠右對齊
    Range("F:F,H:H,J:J").Select
    With Selection
        .NumberFormatLocal = "#,##0"
        .HorizontalAlignment = xlRight
    End With
    
  'S7-4 表格標題，將 序號 A1 格式複製到 A1~J1 > 設定自動換行
    Range("A1").Copy
    With Range("A1:J1")
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Rows.AutoFit
        .WrapText = True
    End With
    
'S8 設定儲存格最後停留位置
    Range("A1").Select