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

现在，你的第一个循环并没有真正做任何事情。这只是不必要的＆＃34;触摸＆＃34;每张表，然后转到其余代码。

很可能，您希望采取您想要执行的每项操作并将其置于循环中。

此外，当您打开多本图书时，请使用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循环的每次迭代中导出。如果是后者，您可能希望将数组转换为多维数组，并在循环的每次迭代中增加其大小。

你清理了这个部分，你应该对导出很好。它是循环遍历数组而不是循环遍历行的问题，这应该可以加快速度。

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

1 个答案: