Sub數(shù)據(jù)輪換()
    Dim myVal(), i As Integer, j As Integer
    On Error Resume Next        '排錯
    j=Selection.Areas.Count   '統(tǒng)計選擇了多少個單元格區(qū)域
    ReDim myVal(1 To j)         '重新定義數(shù)組
    With Selection
      For i=1 To j
      '如果各個區(qū)域大小不一致，則退出程序
      If .Areas(1).Cells.Count <> .Areas(i).Cells.Count Then Exit Sub
      Next i
      For i=1 To j
        myVal(i)=.Areas(i).Value
      Next i
      .Areas(1)=myVal(j)
      For i=1 To j
        .Areas(i+1)=myVal(i)
      Next i
    End With
End Sub

activecll.Font.Name="宋體"
activecll.Font.FontStyle="加粗 傾斜"
activecll.Font.Size=10
activecll.Font.ThemeColor=xlThemeColorLight2
activecll.Font.TintAndShade=0.4
activecll.Font.ThemeFont=xlThemeFontMinor

With activecll.Font
    .Name="宋體"
    .FontStyle="加粗 傾斜"
    .Size=10
    .ThemeColor=xlThemeColorLight2
    .TintAndShade=0.4
    .ThemeFont=xlThemeFontMinor
End With

Sub填充()
Dim rng As Range
  Set rng=Range("A2:A" & Cells(1048576, 2).End(xlUp).Row)
  With rng
    .Select '選擇A列數(shù)據(jù)
    .SpecialCells(xlCellTypeBlanks).Select     '選擇空白單元格
    Selection.FormulaR1C1="=R[-1]C"         '輸入公式
    rng=.Value                          '將公式轉(zhuǎn)換為值
  End With
End Sub

Sub填充公式()
Dim rng As Range, rg As Range
For Each rng In Range("d4:d" & Range("c1048576").End(xlUp).Row)
    Range("d3").Copy
    If rng="" And VBA.IsNumeric(rng.Offset(0,-1)) And rng.Offset
            (0,-1) <> "" Then
      If rg Is Nothing Then
          Set rg=rng
          Set rg=Application.Union(rg, rng)
      End If
    End If
Next
rg.Select
ActiveSheet.Paste
Range("d3").Select
End Sub

Sub選擇性粘貼_連接()
    Dim a As Byte, b As Range, rng As Range
    If Selection.Count > 1 Or Selection="" Then MsgBox "請選擇單個非空
          單元格再執(zhí)行本程序", 64, "提示": Exit Sub
    a=Application.InputBox("1為鏈接在前；2為鏈接在后。", "請輸入鏈接選項",
          "1", 100, 100, Type:=1)
    Set b=Application.InputBox("請輸入粘貼區(qū)域：","區(qū)域","a1",100,100,
          Type:=8)
    For Each rng In b
      If a=1 Then
          rng=Selection.Text & rng.Text
      ElseIf 2=2 Then
          rng=rng.Text & Selection.Text
      End If
    Next
End Sub

Sub清除未采用之方案()
    Dim rng As Range
    For Each rng In Range([c2], Cells(1048576, 3).End(xlUp))
    If rng="不采用" Then     '限定條件
      rng.EntireRow.Delete      '符合條件的都刪除整行
    End If
    Next                   '檢測下一個
End Sub

Sub清除空白數(shù)據(jù)行()
    Dim i As Long
    For i=Cells(1048576, 1).End(xlUp).Row To 2 Step-1
    If WorksheetFunction.CountA(Cells(i, 1).EntireRow)=1 Then'限定條件
    Cells(i, 1).EntireRow.Delete      '符合條件的都刪除整行
    End If
    Next                   '檢測下一個
End Sub

For counter=start To end [Step step]
[statements]
[Exit For]
[statements]
Next [counter]

Sub清除空白數(shù)據(jù)行()
    Dim i As Long
    For i=Cells(1048576, 2).End(xlUp).Row To 3 Step-1
    If Cells(i, 3)="" Then             '如果單元格為空白
    Cells(i, 1).EntireRow.Delete          '符合條件的都刪除整行
    End If
    Next                             '檢測下一個
End Sub

Sub排除空格()
 ActiveSheet.UsedRange.Replace What:=" ", Replacement:="", LookAt:=xlPart
End Sub

Sub隱藏與取消()
    MsgBox "現(xiàn)在隱藏第六行", 64, "隱藏"
    Rows(6).Hidden=True
    MsgBox "現(xiàn)在取消所有隱藏", 64, "全部顯示"
    Cells.EntireRow.Hidden=False
    MsgBox "現(xiàn)在隱藏第六行和第九行", 64, "隱藏"
    Range("6:6,9:9").EntireRow.Hidden=True
    MsgBox "現(xiàn)在取消所有隱藏", 64, "全部顯示"
    Cells.EntireRow.Hidden=False
    MsgBox "現(xiàn)在隱藏第六至第九行", 64, "隱藏"
    Rows("6:9").Hidden=True
    MsgBox "現(xiàn)在取消所有隱藏", 64, "全部顯示"
    Cells.EntireRow.Hidden=False
End Sub

Sub匯總()
    Dim i&, tim&, j%
    tim=Hour(Now()) * 3600+Minute(Now()) * 60+Second(Now())
    Application.ScreenUpdating=False          '禁止刷新屏幕
    Sheet2.Cells.Clear                       '清除原數(shù)據(jù)
    Rows("1:3").Copy Sheet2.Range("a1")         '復(fù)制標(biāo)題
    Sheet2.Columns("d:f").Delete Shift:=xlToLeft
    For i=4 To Range("A1048576").End(xlUp).Row
                          '給變量i賦值，從4到A列最后一個非空行數(shù)
    Cells(i, "j")=Cells(i, "b") & Cells(i, "c") & Cells(i, "d")
                          '在j列產(chǎn)生一個輔助列
    Next                                               '重復(fù)下一個
    With Sheet2
    For i=4 To Range("A65536").End(xlUp).Row
                          '給變量i賦值，從4到A列最后一個非空行數(shù)
      If .Columns("I").Find(Cells(i, "j")) Is Nothing Then
                          '如果匯總表I列不存在輔助列J列之?dāng)?shù)據(jù)
  Range("b" & i & ":e" & i).Copy .Range("A1048576").End(xlUp).
    Offset(1, 0)  '將A列除外的本行數(shù)據(jù)復(fù)制到匯總表
    '對數(shù)量和金額進行條件匯總
  .Range("A1048576").End(xlUp).Offset(0, 4)=
        Application.WorksheetFunction.SumIf(Range("j4:j1048576"),
        Cells(i, "j"),Range("H4:H1048576"))
  .Range("A1048576").End(xlUp).Offset(0, 5)=
        Application.WorksheetFunction.SumIf(Range("j4:j1048576"),
        Cells(i, "j"),Range("I4:I1048576"))
  .Range("A1048576").End(xlUp).Offset(0, 6)=Cells(i, "j")
  .Range("A1048576").End(xlUp).Offset(0, 3)=Cells(i, "g")
  End If
Next
.Columns("g").Delete                  '刪除輔助列
End With
Columns("j").Delete                   '刪除輔助列
MsgBox "運行時間總共" & (Hour(Now()) * 3600+Minute(Now()) * 60+
    Second(Now()))-tim & "秒！", vbOKOnly, "運行完畢"'報告運行時間
Application.ScreenUpdating=True        '禁止刷新屏幕
Call邊框
End Sub
Private Sub邊框()
Sheet2.Activate
Sheet2.Range("A3:f" & [f1048576].End(xlUp).Row).Select
With Selection.Borders      '邊框
.LineStyle=xlContinuous    '線型
.Weight=xlThin           '粗細(xì)
End With
End Sub

Sub匯總行列值()
    Dim rng1, rng2, r As Integer, c As Integer, i As Integer, j As Integer,
          myArray As Variant, Selectionss  As Range
    Set Selectionss=Application.InputBox("請輸入?yún)R總區(qū)域(不含標(biāo)題行)" &
          Chr(10) & "也可以用鼠標(biāo)選擇區(qū)域", "定位", , 0, 0, , , 8)
    With Selectionss
      r=.Rows.Count: c=.Columns.Count
      myArray=.Resize(r+1, c+1)
      Application.ScreenUpdating=False
      rng1=.Offset(-1, 0)
      rng2=.Offset(0,-1)
      .Offset(-1, 1)="匯總"
      .Offset(-1, 0)=rng1
      .Offset(1,-1)="匯總"
      .Offset(0,-1)=rng2
      For i=1 To r
          For j=1 To c
              myArray(i, c+1)=myArray(i, c+1)+myArray(i, j)
        myArray(r+1, j)=myArray(r+1, j)+myArray(i, j)
        myArray(r+1, c+1)=myArray(r+1, c+1)+myArray(i, j)
    Next j
  Next i
  .Resize(r+1, c+1)=myArray
End With
Application.ScreenUpdating=True
End Sub

range("a1").Resize(2,2)