2014-11-07 9 views
1

Мне нужно экспортировать несколько диапазонов из разных таблиц в один текстовый файл. Я хочу, чтобы диапазоны ячеек добавлялись один за другим. В настоящее время я использую этот код, который отлично работает для одного диапазона на одном листе, что мне нужно изменить, чтобы он работал с большим количеством диапазонов?Экспорт нескольких диапазонов в txt-файл

Пример диапазонов Я хотел бы добавить

Sheet1 A2:E50 
Sheet2 A2:F60 
Sheet4 A2:C45 

Текущий код

Sub Export() 
Dim r As Range, c As Range 
Dim sTemp As String 

Open Workbooks("Test.xlsm").Path & "\Test.SQL" For Output As #1 
For Each r In Worksheets("SQL1").Range("A1:D50").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 
End Sub 
+0

Вот альтернативный способ сделать это ... Скопируйте соответствующие диапазоны в новую книгу, а затем сохранить эту книгу как CSV? –

+0

уже думал об этом, и его не очень жизнеспособно, учитывая, что около 10 000 строк ячеек им экспортируется, что является причиной того, что мне действительно нужно изменить этот код. – Windmill

+0

Тем более, что нужно сделать это с помощью подхода, о котором я говорил :) Гораздо лучше, чем зацикливание, хотя 10000 строк ячеек? ;) –

ответ

0

Как я уже говорил в приведенном выше комментарий это самый быстрый способ, которым Вы можете экспортировать эти диапазоны в текстовый файл. Нет перекручивание требуется ...

Непроверено

Dim Thiswb As Workbook, thatWb As Workbook 

Sub Sample() 
    Set Thiswb = ThisWorkbook 
    Set thatWb = Workbooks.Add 

    CopyRange Thiswb.Sheets("Sheet1"), Thiswb.Sheets("Sheet1").Range("A1:E10000") 
    CopyRange Thiswb.Sheets("Sheet2"), Thiswb.Sheets("Sheet2").Range("A1:F10000") 
    CopyRange Thiswb.Sheets("Sheet3"), Thiswb.Sheets("Sheet3").Range("A1:C10000") 

    Application.DisplayAlerts = False 
    thatWb.SaveAs "C:\Temp.csv", xlCSV 
    Application.DisplayAlerts = True 
End Sub 

Sub CopyRange(ws As Worksheet, rng As Range) 
    Dim lRow As Long 

    lRow = thatWb.Sheets(1).Range("A" & thatWb.Sheets(1).Rows.Count).End(xlUp).Row + 1 

    rng.Copy thatWb.Sheets(1).Range("A" & lRow) 
End Sub 

Followup от комментариев

Сиддхарт это, но привычка жилые работы для меня, так как мой выше код встраивается в к SQL и JAVA, вы можете показать мне, как изменить мой код выше, чтобы выполнять многоуровневые диапазоны на разных листах, независимо от того, что это был лучший метод, к сожалению, он не очень хорош с VBA :(- Windmill 5 мин назад

Это то, что вы пытаетесь? (Непроверено)

Sub Sample() 
    Dim Thiswb As Workbook 
    Set Thiswb = ThisWorkbook 

    Export Thiswb.Sheets("Sheet1").Range("A2:E50") 
    Export Thiswb.Sheets("Sheet2").Range("A2:F60") 
    Export Thiswb.Sheets("Sheet4").Range("A2:C45") 
End Sub 

Sub Export(rng As Range) 
    Dim r As Range, c As Range 
    Dim sTemp As String 

    '~~> Use Append instead of Output 
    Open Workbooks("Test.xlsm").Path & "\Test.SQL" For Append As #1 

    For Each r In rng.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 
End Sub 
+0

Siddharth это полезно, но не работает для меня, так как мой выше код подключается к SQL и JAVA, можете ли вы показать мне, как изменить мой код выше, чтобы выполнить мультипульс диапазоны на разных листах, независимо от того, что это был лучший метод, к сожалению, он не очень хорош с VBA :( – Windmill

+0

См. обновленное сообщение ... Возможно, вам придется обновить его –

+0

Когда я запустил код примера, ошибки в этой строке -> Открыть Workbooks ("Test.xlsm"). Path & "\ Test.SQL" для добавления как # 1 – Windmill

Смежные вопросы