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循環的每次迭代中導出。如果是後者，你可能想將數組轉換成一個多維數組，並加大對循環的每個迭代的大小。

一個你有這部分清理，你要善於與出口。這將是通過數組循環，而不是通過行，應該加快速度有點循環的問題。