包装合并的单元格，删除带有单元格的行“” Excel VBA

Question

我有两张床单。在第一个上填写所需的信息，另一个基本上是 Sheet(1) 中信息所在的模板。

Sheet(2) 中充满了 =IF(Sheet(1)!A1=””;””;Sheet(1)!A1) 等公式。
所以在 Sheet(2) 上有很多带有“”的值，它们基本上是空白的。如果此行中没有文本，我想删除整行。

所以如果行看起来像：

A33(“”) B33(“”) C33(“”) D33(“”) E33(“”) F33(“”) G33(一些文本) H33(“”) I33(“”) – 它应该留下

A34(“”) B34(“”) C34(“”) D34(“”) E34(“”) F34(“”) G34(“”) H34(“”) I34(“”) – 应该被删除

同样在工作表 (2) 上，我已合并单元格，工作表 (1) 中相应单元格的文本不适合其中。我想将它们在 Sheet(2)!B31:D68（B31:D31 和 B32:D32 等）范围内的这些单元格包装起来。

这是我的代码，但例如合并单元格的 Wrap 不起作用。代码隐藏了我需要删除它们的行。代码还隐藏了带有我在 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

如果您在启动之前取消合并 Sheet(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