VBA 仅导出包含数据的单元格

Question

我正在尝试浏览工作簿中的许多工作表，并且仅从 B 列中包含数据的单元格中导出数据。

现在导出非常慢，因为我选择了 B 列中的所有内容并将其写入文本文件。

我是 VBA 新手，这个宏是从在线搜索中组合起来的。

Sub Export()
Application.ScreenUpdating = False
Application.EnableEvents = False
'Remember original sheet
Set mySheet = ActiveSheet

For Each sht In ActiveWorkbook.Worksheets
    sht.Activate
    Columns("B").Select
Next sht

Dim myFile As String, cellValue As Variant, rng As Range, i As Long, j As Integer
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
myFile = fso.GetBaseName(ActiveWorkbook.Name) & ".txt"
Set rng = Selection
Open myFile For Output As #1
       For i = 1 To rng.Rows.Count
            For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
    Write #1, cellValue
Else
    Write #1, cellValue,
End If
    Next j
Next i
Close #1
'Remove extra quotes
Dim r As Range, c As Range
Dim sTemp As String
Open myFile For Output As #1
For Each r In Selection.Rows
    sTemp = ""
    For Each c In r.Cells
        sTemp = sTemp & c.Text & Chr(9)
    Next c
    'Get rid of trailing tabs
    While Right(sTemp, 1) = Chr(9)
        sTemp = Left(sTemp, Len(sTemp) - 1)
    Wend
    Print #1, sTemp
Next r
Close #1
'Return to original sheet
mySheet.Activate
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Done"
End Sub

编辑:

我可以快速导出当前工作表上具有值的单元格。它不会循环遍历所有工作表。

For Each ws In ThisWorkbook.Worksheets
    Range("B12:B1746").SpecialCells(xlCellTypeConstants, xlTextValues).Select
Next ws

编辑2:

这行得通，但我会继续努力。随意添加建议。

Sub CopyRangeFromMultiWorksheets()
'Remember original sheet
Set mySheet = ThisWorkbook.ActiveSheet
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ThisWorkbook.Worksheets
    'Error if not unprotected first
    'ActiveSheet.Unprotect Password:=""
    If sh.Name <> DestSh.Name Then

        'Find the last row with data on the DestSh
        Last = LastRow(DestSh)

        'Fill in the range that you want to copy
        Set CopyRng = sh.Range("B12:B1746").SpecialCells(xlCellTypeConstants, xlTextValues)

        'Test if there enough rows in the DestSh to copy all the data
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If

        'This example copies values/formats, if you only want to copy the
        'values or want to copy everything look at the example below this macro
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With

        'Optional: This will copy the sheet name in the H column
        DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

'Copy to txt
Dim iCntr
Dim myFile As String
Dim strFile_Path As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
myFile = fso.GetBaseName(ActiveWorkbook.Name) & ".txt"
Open myFile For Output As #1
For iCntr = 1 To LastRow(DestSh)
Print #1, Range("A" & iCntr)
Next iCntr
Close #1
'Remove helper sheet without alert
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("RDBMergeSheet").Delete
Application.DisplayAlerts = True
'Return to original sheet
mySheet.Activate
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Done"
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

Answer 1

你在这里遇到了一个多步骤的问题。我将尝试在高层次上涵盖最大的项目，以使您更容易依次解决(或提出后续问题)每个单独的问题。

为了循环工作表，您可能需要这样的东西:

For Each ws In ThisWorkbook.Worksheets

    ' Insert your main actions within here, instead of after here

Next ws

现在，你的第一个循环并没有真正做任何事情。它只是不必要地“触摸”每张纸，然后继续处理其余的代码。

更有可能的是，您需要执行您想要执行的每个操作并将它们放在循环中。

另外，请使用 ThisWorkbook而不是 ActiveWorkbook当您打开多本书时避免边缘情况问题。

因为您遇到速度问题，所以最好尽量避免 Select或 Activate每当您复制列时。尝试这样的事情:

...
Const RANGE_BASE As String = "B1:B"
Dim rangeToImport As String
Dim Items() As Variant

rangeToImport = RANGE_BASE & CStr(ReturnLastUsedRow(ws:=ws))
Items = ws.Range(rangeToImport)
...

Private Function ReturnLastUsedRow(ByVal ws As Worksheet) As Long

    Const CUTOFF_ROW As Long = 1000000
    Const SELECTED_COLUMN As String = "B"

    ReturnLastUsedRow = ws.Cells(CUTOFF_ROW, SELECTED_COLUMN).End(xlUp).Row

End Function

上面对列进行了硬编码(而不是仅仅依赖于事件的内容)。然后，它将给定列的内容保存到一个数组中，供您以后使用。

提供了一个单独的辅助函数来帮助确定范围的最大长度。这是为了确保您不会遍历每一行，而只是遍历其中包含内容的行。

我不确定您是否需要单独导出列，或者是否需要将它们作为一个整体导出？如果是前者，那么您应该能够在 For 循环的每次迭代中导出。如果是后者，您可能希望将数组转换为多维数组，并在循环的每次迭代中增加其大小。

你已经清理了这部分，你应该对导出很好。这将是遍历数组而不是遍历行的问题，这应该会加快速度。