包装合并的单元格，删除单元格的行Excel Excel VBA

Question

我有两个表格。第一个填写需要的信息，另一个基本上是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 “”）H34（“”）I34（“”） - 应该被删除

同样在表（2）上，我已经合并单元格和来自Sheet（1）中相应单元格的文本不适合那里。我想将这些单元格放在范围表（2）！B31：D68（B31：D31和B32：D32等）中进行合并。

这是我的代码，但例如Wrap for merged cells does not work。代码隐藏了我需要删除的行。代码也是将Sheet（2）中的文本隐藏在来自Sheet（1）的结果中。

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 

Answer 1

，如果你取消合并单元格中的表（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