Question

这个VBA有效。它创建一个新工作表，然后复制列（45）中的每个和所有单元格，包括空白单元格。如何让它不复制空白/单元格或不包含任何值的单元格？我知道一旦将所有内容合并到新工作表中，我就可以使用过滤功能进行空白，但我想跳过这一步。

Sub merge()
    Dim Sh As Worksheet, ShM As Worksheet, i&, z&
    Application.ScreenUpdating = 0
    Set Sh = Worksheets.Add(, Sheets(Sheets.Count))
    Sh.Name = "consolidated"
    For Each ShM In ThisWorkbook.Worksheets
        If ShM.Name <> Sh.Name Then
            i = ShM.Cells(Rows.Count, 45).End(xlUp).Row
            ShM.Activate: ShM.Range(Cells(1, 45), Cells(i, 45)).Copy
            Sh.Activate: Sh.Cells(z, 1).PasteSpecial xlPasteValues
        End If
    Next ShM
    Application.ScreenUpdating = 1
End Sub

Answer 1

有几种方法可以做到这一点，但最简单的方法之一是复制数据然后删除那些空白：

Sub merge()
    Dim Sh As Worksheet, ShM As Worksheet, i&, z& *Application.ScreenUpdating = 0
    z = 1
    Set Sh = Worksheets.Add(, Sheets(Sheets.Count))
    Sh.Name = "consolidated"
    For Each ShM In ThisWorkbook.Worksheets
        If ShM.Name <> Sh.Name Then
            i = ShM.Cells(Rows.Count, 45).End(xlUp).Row
            ShM.Activate: ShM.Range(Cells(1, 45), Cells(i, 45)).Copy
            Sh.Activate: Sh.Cells(z, 1).PasteSpecial xlPasteValues
            z = z + 1
        End If
        For i = Sh.Cells(Rows.Count,45).End(xlUp).Row to 1 Step -1
            If Sh.Cells(i,45).Value = "" Then Sh.Cells(i,45).EntireRow.Delete
        Next i
    Next ShM
    Application.ScreenUpdating = 1
End Sub

Answer 2

下面的代码使用数组来获取原始值并消除空白值（来自空白单元格或作为公式的结果）。它还会在合并 Wsh中的 A 列中输入结果数据，在工作表数据之间留下一个空行，以确保不会发生重叠，并且两行空白分隔当工作表只有空白值时。还使用常量来标识目标列（此示例中的第5列，只是根据需要进行了更改）

Option Explicit
Option Base 1

Sub Wsh_MergeColDataFromAllOterWorksheets()
Const kCol As Byte = 5
Dim Sh As Worksheet, ShM As Worksheet, i As Long, z As Long
Dim aAryInput As Variant, vAryOutput() As Variant
Dim vCllVal As Variant
Dim l As Long

    Rem Add New Worksheet
    Application.ScreenUpdating = 0
    Set Sh = Worksheets.Add(After:=Sheets(Sheets.Count))

    Rem Delete Consolidate Wsh if present
    Application.DisplayAlerts = 0
    On Error Resume Next
    Worksheets("consolidated").Delete
    On Error GoTo 0
    Application.DisplayAlerts = 0

    Rem Add New Worksheet
    Sh.Name = "consolidated"

    z = 1
    For Each ShM In ThisWorkbook.Worksheets
        With ShM
            If .Name <> Sh.Name Then

                Rem Get Last Row
                i = .UsedRange.SpecialCells(xlCellTypeLastCell).Row

                Rem Set Input Array
                aAryInput = Empty
                aAryInput = .Range(.Cells(1, kCol), .Cells(i, kCol))

                Rem Initiate & Size Output Array
                Erase vAryOutput
                ReDim Preserve vAryOutput(i)

                Rem Get Non Blank Cells Value
                l = 0
                For Each vCllVal In aAryInput
                    If WorksheetFunction.Trim(vCllVal) <> Empty Then
                        l = 1 + l
                        vAryOutput(l) = vCllVal
                End If: Next

            If l <> 0 Then
                Rem Erase Blank Values in Output Array
                ReDim Preserve vAryOutput(l)
                vAryOutput = WorksheetFunction.Transpose(vAryOutput)

                Rem Set NonBlank Values in Wsh "consolidated" (Column 1)
                Sh.Cells(z, 1).Resize(l).Value = vAryOutput
            End If

            Rem Set Next Row
            z = 1 + z + l

    End If: End With: Next ShM
    Application.ScreenUpdating = 1

End Sub

VBA复制列，包括所有空白单元格

2 个答案: