使用 VBA 将 orasql 查询拆分为 Excel 中的多个工作簿 [关闭]

Question

我正在尝试将我的 ORASQL 查询拆分为多个工作簿，每本书都有指定数量的条目。如果这很重要，我正在使用 Office 2010。我想我应该使用下面的内容（来自上一个关于行数的示例）来获取计数，然后我可以使用它来拆分工作表。

With ThisWorkbook.Sheets("Sheet1")
    recct = .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Rows.Count
End With

1. 我不知道从哪里开始，因为我还没有 VBA 方面的经验，而且
2. 我认为 RecordCount 或类似的东西可能有更好的方法。

添加细节和澄清：

• 我在 VBA 中运行 sql 查询。
• 它将包含约 176k 行的列表返回到一个工作簿的一张表中，其中包含 9 个不同的列 (A-I)。
• 我想将 176k 行中的信息（一次 30k）复制到单独的工作簿中，并将它们保存到特定路径。

这是全部内容，减去我的 orcal 连接信息

Sub pull_paper_claims()

Dim ym As Variant

Dim sql As String

Dim recct As Long


ym = Range("B2").Value

Set oConOracle = CreateObject("ADODB.Connection")

Set oRsOracle = CreateObject("ADODB.Recordset")


sql = "select  unique payor_name, payor_addr1, payor_city, payor_zip, payor_state, taxid, pat_account, act_id, payor_id from lisa.cc_data_" & ym & " where claim_status='p' and payor_id!='cpapr'and payor_id!='hpapr' and payor_id!='xpapr'"

'oracle connection

oConOracle.Open "my conection information"

Set oRsOracle = oConOracle.Execute(sql)

'clear it up first

Range("A3", "K200000").ClearContents  

Range("A3").CopyFromRecordset oRsOracle

With ThisWorkbook.Sheets("Sheet1")
  recct = .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Rows.Count
End With

Range("A1").Value = recct

'close the statement

oConOracle.Close

Set oRsOracle = Nothing

Set oConOracle = Nothing

'ActiveWorkbook.SaveAs Filename:="D:\important\job_stats_" & Format(end_date, "yyyymmdd") & ".xlsx", FileFormat:=xlOpenXMLWorkbook

End Sub

添加以回答您的问题。

我确实将您的内容复制到了一个新的子中，并且几乎没有改变。

Sub Create_new_wb()
Const numRow = 30000 'constant for number of rows in each copy
Dim lRow As Long 'variable to contain the last row information
Dim lCol As Long 'variable to contain the last column information
Dim wbk As Workbook
Dim i As Long
Dim aryData() As Variant

'find lrow and lcolumn in data sheet
lRow = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column

'loop through number of times required to part all data
For i = 1 To Application.RoundUp(lRow / numRow)
    'determine size of aray and put data into array
    If lRow > i * numRow Then
        ReDim aryData(1 To i * numRow, 1 To lCol)
        aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(numRow, lCol)
    Else
        ReDim aryData(1 To lRow - (numRow * i))
        aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(lRow - (numRow * i), lCol)
    End If

    'add new workbook and paste data
    Set wbk = Workbooks.Add()
    wbk.Sheets(1).Cells(1, 1).Resize(UBound(aryData, 1), UBound(aryData, 2)) = aryData
    'save and close workbook
    wbk.SaveAs Filename:="C:\temp\" & "NewBook" & i & ".xlsx"
    wbk.Close
Next
End Sub

Answer 1

有两种方法可以做到这一点

1. 从 pull 宏修改它，使其填充多个工作簿并保存到不同的位置
2. 编写后处理宏以复制数据并放入新工作簿中

您可以从方法 2 开始，稍后将其集成到 pull 宏中。 下面是方法 2 的样子：

Sub Test()
    Const numRow = 30000 'constant for number of rows in each copy
    Dim lRow As Long 'variable to contain the last row information
    Dim lCol As Long 'variable to contain the last column information
    Dim wbk As Workbook
    Dim i As Long
    Dim aryData() As Variant

    'find lrow and lcolumn in data sheet
    lRow = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column

    'loop through number of times required to part all data
    For i = 1 To Application.RoundUp(lRow / numRow)
        'determine size of aray and put data into array
        If lRow > i * numRow Then
            ReDim aryData(1 To i * numRow, 1 To lCol)
            aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(numRow, lCol)
        Else
            ReDim aryData(1 To lRow - (numRow * i))
            aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(lRow - (numRow * i), lCol)
        End If

        'add new workbook and paste data
        Set wbk = Workbooks.Add
        wbk.Name = "NewBook" & i & ".xlsx"
        wbk.Sheets(1).Cells(1, 1).Resize(UBound(aryData, 1), UBound(aryData, 2)) = aryData
        'save and close workbook
        wbk.SaveAs Filename:="C:\temp\" & wbk.Name
        wbk.Close
    Next
End Sub

如果这有帮助，请告诉我！