将合并的单元格换行，删除单元格为“Excel VBA”的行
我有两张表。 在第一个填写所需的信息，另一个基本上来自Sheet（1）的信息模板。
工作表（2）中充满了类似于= IF（Sheet（1）！A1 =“”;“”; Sheet（1）！A1）的公式。
所以在表（2）是很多值与“”，基本上是空白的。 如果在这一行没有文本，我想删除整行。
所以如果这行看起来像：
A33（“”）B33（“”）C33（“”）D33（“”）E33（“”）F33（“”）G33（有些文字）H33（“”）I33
A34（“”）B34（“”）C34（“”）D34（“”）E34（“”）F34（“”）G34（“”）H34（“”）I34
另外在表（2）上，我已经合并单元格和来自Sheet（1）中的相应单元格的文本不适合那里。 我想把这些单元格放在范围表（2）中！B31：D68（B31：D31和B32：D32等）被合并。
这是我的代码，但例如Wrap for merged cells does not work。 代码隐藏了我需要删除的行。 代码也是通过Sheet（1）中的结果将Sheet（2）中的文本隐藏起来。
Sub AutofitRows() Dim CL As Range For Each CL In ActiveWorkbook.Sheets(2).Range("A30:I68") If CL.WrapText Then CL.rows.AutoFit Next End Sub Sub removecellswithemptycells() ActiveWorkbook.Sheets(2).Select Set rr = Range("A30:J66") For Each cell In rr cell.Select If cell.HasFormula = True And cell.Value = "" And cell.EntireRow.Hidden = False Then rows(cell.Row).EntireRow.Hidden = True Next cell End Sub Sub removecellswithemptycells_pos2() ActiveWorkbook.Sheets(2).Select Set rr = Range("A21:J22") For Each cell In rr cell.Select If cell.HasFormula = True And cell.Value = "" And cell.EntireRow.Hidden = False Then rows(cell.Row).EntireRow.Hidden = True Next cell End Sub Sub dothefiles() Dim NewPath As String Dim iFileName$, iRow& NewPath = Application.ThisWorkbook.Path & "\" & "Order" If Dir(NewPath, 63) = "" Then MkDir NewPath ActiveWorkbook.Sheets(2).Select ActiveSheet.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=NewPath & "\" & [Sheet(1)!C17] & "-" & [Sheet(1)!C6] & " " & "Order" & " " & [Sheet(1)!C10] & " " & Date & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=No, _ OpenAfterPublish:=False iFileName = NewPath & "\" & [Sheet(1)!C17] & "-" & [Sheet(1)!C6] & " " & "Order" & " " & [Sheet(1)!C10] & " " & Date & ".xls" Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlManual ThisWorkbook.Sheets(2).Copy With ActiveWorkbook.ActiveSheet .Buttons.Delete '.Shapes("Button 1").Delete .UsedRange.Value = .UsedRange.Value For iRow = .Cells(.rows.Count, 2).End(xlUp).Row To 5 Step -1 If Application.CountA(.rows(iRow)) = 1 Then .rows(iRow).Delete Next .SaveAs iFileName, xlExcel8: .Parent.Close End With Application.Calculation = xlAutomatic Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Sub doitallplease() Call AutofitRows Call removecellswithemptycells Call removecellswithemptycells_pos2 Call dothefiles End Sub 这应该正常工作，如果您在启动之前取消合并表（2）中的单元格：
Option Explicit Public tB As Workbook Public wS1 As Worksheet Public wS2 As Worksheet Public wSCopy As Worksheet Sub CreateCleanCopies() Dim NewPath As String Dim iFileName$, iRow& With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .Calculation = xlManual End With 'Application Set tB = ThisWorkbook Set wS1 = tB.Sheets(1) Set wS2 = tB.Sheets(2) NewPath = tB.Path & "\" & "Order" iFileName = NewPath & "\" & wS1.Range("C17") & "-" & wS1.Range("C6") & " " & "Order" & " " & wS1.Range("C10") & " " & Date & ".pdf" If Dir(NewPath, 63) = vbNullString Then MkDir NewPath wS2.Copy Set wSCopy = ActiveWorkbook.ActiveSheet AutofitRowsAndMerge wSCopy, "A30:I68" RemoveEmptyRows wSCopy, "A30:J66" RemoveEmptyRows wSCopy, "A21:J22" With wSCopy .ExportAsFixedFormat _ Type:=xlTypePDF, _ FileName:=iFileName, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False iFileName = Replace(iFileName, ".pdf", ".xls") .Buttons.Delete .UsedRange.Value = .UsedRange.Value .Parent.SaveAs iFileName, xlExcel8 .Parent.Close End With With Application .DisplayAlerts = True .Calculation = xlAutomatic .EnableEvents = True .ScreenUpdating = True End With 'Application End Sub Sub AutofitRowsAndMerge(wS As Worksheet, RangeAddress As String) Dim RgCL As Range For Each RgCL In wS.Range(RangeAddress).Columns(1).Cells With RgCL If Not .WrapText Then .WrapText = True .EntireRow.AutoFit .Parent.Range(RgCL, .Offset(0, 2)).Merge End With 'RgCL Next RgCL End Sub Sub RemoveEmptyRows(wS As Worksheet, RangeAddress As String) Dim RemoveRow As Boolean Dim i As Double Dim LastRgRow As Double Dim FirstRgRow As Double Dim RgCL As Range With wS.Range(RangeAddress) FirstRgRow = .Cells(1, 1).Row LastRgRow = .Cells(.Rows.Count, 1).Row End With 'wS.Range(RangeAddress) For i = LastRgRow To FirstRgRow Step -1 RemoveRow = True For Each RgCL In Application.Intersect(wS.Range(RangeAddress), wS.Rows(i)).Cells If RgCL.Value <> vbNullString Then RemoveRow = False Exit For Else End If Next RgCL If RemoveRow Then wS.Rows(i).EntireRow.Delete Next i End Sub