2016-11-30 17 views
0

Myマクロは、アクティブブック内のすべてのシートのすべてのデータを書き込むことによって大きなテキストファイルを作成します。すべての関連するセルのExcel VBA範囲

各ワークシートでは、テキストファイルに保存される特定の矩形範囲のセルを決定する必要があります。左上隅は常にA1になりますが、右下隅は、範囲にすべてのセルが含まれるように選択する必要があります(書式設定は関係ありません)。

私はws.Range( "A1")と思っていましたが、CurrentRegionはトリックを行いますが、A1と近くのセルが空の場合は動作しません。シート内のデータを含む唯一のセルがQ10の場合、範囲はA1:Q10でなければなりません。

もちろん、興味のある範囲を見つけるためにws.Cellsの範囲をループすることができますが、それはかなり時間がかかります。より効果的な方法があることを願っています。シート内のすべてのセルを選択してメモ帳にコピー貼り付けすると、何百もの空の列と何千もの空の行が表示されることはなく、関連するデータだけがコピーされます。問題はVBAでそれを複製する方法です。 A1に何があるかどう

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 

:B2細胞は、このマクロ作品

これは、これまでのところ、私のコードです。 A1:B2が空で、CurrentRegionプロパティがEmptyを返すと、ブレークします。

+2

あなたは試しに範囲( "A1")を持っていますか?特別なセル(xllastcell)? – Rosetta

+0

ありがとうございます、SpecialCellsメソッドを指摘すると、これを思い出すのに役立ちました: 'ws.Range(" A1: "&ws.Cells.SpecialCells(xlLastCell).Address)' – Passiday

答えて

0

感謝を願って、次の機能

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

を使用することができます範囲:

ws.Range("A1:" & ws.Cells.SpecialCells(xlLastCell).Address) 
0

私はあなたが、あなたが情報を持つ最後のセルを検索したいシートおよび行/ columb-数の名前を指定しますが、最後の行/列

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

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

を見つけるために、これらの関数を使用すべきだと思いますその数を返します。

はlastColはasnwer限り、あなた与える(最初の行の例では最初の列の最後の行、最後の列が検索されています)。あなたは列の文字には、この番号を変換したい場合、あなたは私が求めてのためにこの表現を作ってみた、ユーザーロゼッタにこの便利な

関連する問題