Excel VBA – 格式表不能按预期工作
我有下面的代码，这是做6件事情; 首先，它会自动调整所有行和列的大小，然后冻结最上面一行，然后根据一个模式更改表单颜色，然后search一个单词并删除任何包含该单词的行，然后将所有数据格式化为一个表格并定向到景观。 然而，当它完成最后一步时，不仅仅是将数据表的格式设置为格式化每一列的数据，而是如果我只运行格式表部分，那么我的工作是否正确呢？ 谢谢！
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 我怀疑问题是由您在第一个例程中设置整个第一行的值引起的。 尝试这样的事情：
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