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 

EDIT:

можно быстро экспортировать ячейки со значением на текущем листе. Он не будет циклически перемещаться по всем листам.

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

EDIT 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 Loop. Если последнее, вы можете захотеть превратить массив в многомерный массив и увеличить его размер на каждой итерации цикла.

У вас есть эта часть, очищенная, вы должны быть хорошо с экспортом. Речь идет о переходе через массив вместо того, чтобы перебирать строки, что должно немного ускорить работу.