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

我正在尝试浏览工作簿中的许多工作表，只从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