Excel VBA Range for all relevant cells

Question

My macro creates a large text file by writing all the data from all sheets in the active workbook.

In each worksheet, it is necessary to determine a certain rectangular range of cells that would be saved in the text file. It's upper left corner would always be A1, but the lower right corner should be chosen so that the range includes all cells with any content (formatting does not matter).

I thought ws.Range("A1").CurrentRegion would do the trick, but it does not work when A1 and the nearby cells are empty. If the only cell with data in the sheet is Q10, then the range should be A1:Q10.

Of course, I could loop over the ws.Cells range to discover the range of interest, but that's quite time consuming, I hope there's more effective way. If I select all cells in a sheet and do a copy-paste to notepad, I do not end up with hundreds of empty columns and thousands of empty rows, only the relevant data are copied. The question is how to replicate that with VBA.

This is my code so far:

Sub CreateTxt()
    'This macro copies the contents from all sheets in one text file
    'Each sheet contents are prefixed by the sheet name in square brackets
    Dim pth As String
    Dim fs As Object
    Dim rng As Range

    pth = ThisWorkbook.Path

    Set fs = CreateObject("Scripting.FileSystemObject")
    Dim outputFile As Object
    Set outputFile = fs.CreateTextFile(pth & "\Output.txt", True)

    Dim WS_Count As Integer
    Dim ws As Worksheet
    Dim I As Integer

    WS_Count = ActiveWorkbook.Worksheets.Count

    For I = 1 To WS_Count
        Set ws = ActiveWorkbook.Worksheets(I)
        outputFile.WriteLine ("[" & ws.Name & "]")
        Debug.Print ws.Name
        Set rng = ws.Range("A1").CurrentRegion
        outputFile.WriteLine (GetTextFromRangeText(rng, vbTab, vbCrLf))
    Next I

    outputFile.Close
End Sub

Function GetTextFromRangeText(ByVal poRange As Range, colSeparator As String, rowSeparator As String) As String
    Dim vRange As Variant
    Dim sRow As String
    Dim sRet As String
    Dim I As Integer
    Dim j As Integer

    If Not poRange Is Nothing Then

        vRange = poRange

        Debug.Print TypeName(vRange)
        For I = LBound(vRange) To UBound(vRange)
            sRow = ""
            For j = LBound(vRange, 2) To UBound(vRange, 2)
                If j > LBound(vRange, 2) Then
                    sRow = sRow & colSeparator
                End If
                sRow = sRow & vRange(I, j)
            Next j
            If sRet <> "" Then
                sRet = sRet & rowSeparator
            End If
            sRet = sRet & sRow
        Next I
    End If

    GetTextFromRangeText = sRet
End Function

if there is anything in A1:B2 cells, this macro works. It breaks when the A1:B2 is empty and the CurrentRegion property returns Empty.

Thanks, you pointing out to the SpecialCells method helped me to come up with this: ws.Range("A1:" & ws.Cells.SpecialCells(xlLastCell).Address) — Passiday

Martin Router King Martin Router King · Accepted Answer · 2016-11-30T12:23:59

I think you should use these functions to find the last Row/Column

lastRow = Sheets("Sheetname").Cells(Rows.Count, 1).End(xlUp).Row

lastCol = Sheets("Sheetname").Cells(1, Columns.Count).End(xlToLeft).Column

You specify the name of the sheet and the row/columb-number that you want to find the last cell with information, and it return the number of it.

(In the example the last row in first column, and last column in first row are find)

lastCol will give you an Long as an asnwer. If you want to convert this number into the column letter you can use the next function

Function Col_Letter(lngCol As Long) As String
    Dim vArr
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function

I hope you find this useful

Excel VBA Range for all relevant cells

2 Answers