Question

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

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

我不知道从哪里开始，因为我还没有VBA经验和
我认为使用RecordCount可能会有更好的方式。

添加细节并确认：

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

这是整个事情，减去我的orcale连接信息

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

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

从拉宏中修改它，以便它将填充多个工作簿并保存到各个位置
编写后处理宏以复制数据并放入新工作簿

您可以从方法2开始，稍后将其集成到拉宏中。这是方法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

请告诉我这是否有帮助！

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

1 个答案: