Question

我有以下代码，它做了6件事;首先它自动调整所有列和行的大小，然后冻结顶行，然后根据模式更改工作表颜色，然后搜索单词并删除包含该单词的任何行，然后将所有数据格式化为表格并将其定位为景观。然而，当它完成最后一步时，它不仅仅使用数据格式化表格，它将每个列格式化为表格 - 但如果我只运行格式表部分它工作正常，我做错了什么？谢谢！

Sub Test_Macro()
    'This one Auto Sizes All Sheets
    Dim wkSt As String
    Dim wkBk As Worksheet
    Dim temp As Variant

    wkSt = ActiveSheet.Name
    'This Loops Through All Sheets
    For Each wkBk In ActiveWorkbook.Worksheets
      On Error Resume Next
      wkBk.Activate
      temp = wkBk.Rows(1)
      wkBk.Rows(1).ClearContents   'This deletes the first row in case of a header
      wkBk.Columns.EntireColumn.AutoFit
      wkBk.Rows.EntireRow.AutoFit
      wkBk.Rows(1) = temp 'This adds back the first row after formatting
  Next wkBk
  Sheets(wkSt).Select
Call FreezePanes
End Sub

Private Sub FreezePanes()
' This one Freezes Row 1 (under Header)
    Dim s As Worksheet
    Dim c As Worksheet

     ' store current sheet
    Set c = ActiveSheet

     ' Stop flickering...
    Application.ScreenUpdating = False

     ' Loop throught the sheets
    For Each s In ThisWorkbook.Worksheets

         ' Have to activate - SplitColumn and SplitRow are properties
         ' of ActiveSheet
        s.Activate

        With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
        '   .SplitRow = 2 'Depending on if it has a header maybe?
            .FreezePanes = True
        End With

    Next

     ' Back to original sheet
    c.Activate
    Application.ScreenUpdating = True

    Set s = Nothing
    Set c = Nothing
Call Color_All_Sheet_Tabs
End Sub

Private Sub Color_All_Sheet_Tabs()

    Dim iCntr, sht, arrColors, numColors

    arrColors = Array(3, 5, 6, 17) ' array of color indexes

    iCntr = 0
    numColors = UBound(arrColors) + 1 ' how many colors?

    For Each sht In ThisWorkbook.Worksheets
        sht.Tab.ColorIndex = arrColors((iCntr Mod 4)) ' use Mod to cycle color
        iCntr = iCntr + 1
    Next
Call TestDeleteRows
End Sub
Private Sub TestDeleteRows()
Dim rFind As Range
Dim rDelete As Range
Dim strSearch As String
Dim sFirstAddress As String
Dim sh As Worksheet

strSearch = "Completed" ' Search for anything that says Completed and delete that row
Set rDelete = Nothing

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
With sh.Columns("A:AO") ' would maybe like to make this the entire sheet not just an aray
Set rFind = .Find(strSearch, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
If Not rFind Is Nothing Then
    sFirstAddress = rFind.Address
    Do
        If rDelete Is Nothing Then
            Set rDelete = rFind
        Else
            Set rDelete = Application.Union(rDelete, rFind)
        End If
        Set rFind = .FindNext(rFind)
    Loop While Not rFind Is Nothing And rFind.Address <> sFirstAddress

    rDelete.EntireRow.Delete
    Set rDelete = Nothing
End If
End With
Next sh
Application.ScreenUpdating = False
'Call Format_As_Table
End Sub
Private Sub Format_As_Table()
Dim Tbl As ListObject
Dim Rng As Range
Dim sh As Worksheet

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
    With sh
        Set Rng = .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell))
        Set Tbl = .ListObjects.Add(xlSrcRange, Rng, , xlYes)
        Tbl.TableStyle = "TableStyleMedium15"

        .PageSetup.Orientation = xlLandscape
    End With

Next sh
Application.ScreenUpdating = False

End Sub

Private Sub Resize_Columns()
'This one Auto Sizes All Sheets
  Dim wkSt As String
  Dim wkBk As Worksheet
  Dim temp As Variant

  wkSt = ActiveSheet.Name
  ' This Loops Through All Sheets
  For Each wkBk In ActiveWorkbook.Worksheets
      On Error Resume Next
      wkBk.Activate
      temp = wkBk.Rows(1)
      wkBk.Rows(1).ClearContents   'This deletes the first row in case of a header
      wkBk.Columns.EntireColumn.AutoFit
      wkBk.Rows.EntireRow.AutoFit
      wkBk.Rows(1) = temp 'This adds back the first row after formatting
  Next wkBk
  Sheets(wkSt).Select

End Sub

Answer 1

我怀疑问题是由您在第一个例程中设置整个第一行的值引起的。尝试这样的事情：

    Dim lastCol as Long
    For Each wkBk In ActiveWorkbook.Worksheets
      On Error Resume Next
      wkBk.Activate
      lastCol = wkBk.Cells(1, columns.count).End(xlToLeft).Column
      temp = wkBk.cells(1).Resize(, lastcol).Value
      wkBk.Rows(1).ClearContents   'This deletes the first row in case of a header
      wkBk.Columns.EntireColumn.AutoFit
      wkBk.Rows.EntireRow.AutoFit
      wkBk.cells(1).Resize(, lastcol).Value = temp 'This adds back the first row after formatting
  Next wkBk

Excel VBA - 格式表未按预期工作

1 个答案: