VBA export only cells with data

Question

I'm trying to go through many worksheets in a workbook and only export data from cells in column B that contain data.

Right now exporting is very slow since I'm selecting everything in column B and writing it to a text file.

I'm new to VBA and this macro was put together from online searches.

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:

I can quickly export cells with a value on current worksheet. It will not cycle through all worksheets.

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

EDIT 2:

This works, but I'm going to work on it more. Feel free to add suggestions.

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

You've got a bit of a multi-step problem here. I'll try to cover the biggest items at a high-level, to try to make it easier for you to tackle (or ask follow-up questions on) each of the individual issues in turn.

For looping through worksheets, you'll probably want something like this:

For Each ws In ThisWorkbook.Worksheets

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

Next ws

Right now, your first loop isn't really doing anything. It's just unnecessarily "touching" each sheet, and then moving on to the rest of the code.

More than likely, you'll want to take each action you want to do and place them within the loop.

Also, use ThisWorkbook instead of ActiveWorkbook to avoid edge case issues when you have multiple books open.

Because you're having speed issues, it's best to try to avoid Select or Activate whenever you're copying columns. Try something like this:

...
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

The above hard-codes the column (instead of relying simply on what's active). Then, it saves the contents of the given column into an array that you can use later on.

A separate helper function is provided to help determine the max length of your range. This is to ensure that you're not looping through EVERY row, just the ones with stuff in it.

I'm not sure if you need to export the columns individually, or if you need to export them as a whole? If the former, then you should be able to export within each iteration of the For Loop. If the latter, you may want to turn the array into a multi-dimensional array and increase its size on each iteration of the loop.

One you have this part cleaned up, you should be good with the export. It'll be a matter of looping through the array instead of looping through the rows, which should speed things up a little.