Wrap merged cells, delete rows with cells "" Excel VBA

Question

I have two Sheets. On the first one you fill the information needed and another one is basically template where information from Sheet(1) goes.

Sheet(2) is full of formulas like =IF(Sheet(1)!A1=””;””;Sheet(1)!A1).
So on the Sheet(2) is a lot of values with “” that are basically blank. I want to delete entire row if in this row there are no text.

So if the row looks like:

A33(“”) B33(“”) C33(“”) D33(“”) E33(“”) F33(“”) G33(some text) H33(“”) I33(“”) – it should stay

A34(“”) B34(“”) C34(“”) D34(“”) E34(“”) F34(“”) G34(“”) H34(“”) I34(“”) – should be deleted

Also on the Sheet(2) I have merged cells and text from corresponding cell in Sheet(1) does not fit in there. I want to wrap these cells they are in range Sheet(2)!B31:D68 (B31:D31 and B32:D32 and so on) are merged.

Here is my code but for example Wrap for merged cells does not work. Code is hiding the rows I need them to be deleted. Code is also hiding rows with my text in Sheet(2) coming as result from 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

This should work properly if you unmerge the cells in Sheet(2) before launching it:

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