Question

我需要从一个匹配行和列条件的大型Excel中提取数据。我有100或张纸且大于120mb的大型Excel。我需要将数据从该工作簿提取到当前工作簿匹配的工作表名称，列条件和行条件。

我有一个可以执行此操作的代码，但是问题是，如果我每次在后台打开工作簿并关闭它都花费了很多时间。那么，如何不在后台打开它呢？我已经阅读了有关ADO连接的信息，但实际上我不理解代码，也不清楚如何使用excel4macro。

我包括我的代码。我是编码新手，所以我猜会有很多错误。这是出于我的工作目的。

Sub WCDMA_Network_Planning_DumpData_Extract()

Dim ws As Worksheet
Dim wsname As String
Dim wsnamed As String
Dim finalrow As Integer
Dim finalcol As Integer
Dim paraname1() As Variant
Dim columnnumber As Integer
Dim filename As String
Dim cellnm1() As Variant
Dim rownumber As Integer
Dim firstrow As Integer
Dim firstcolumn As Integer
Dim value() As Variant
Dim add As String
Dim firstrow2 As Integer
Dim finalrow2 As Double
Dim firstcolumn2 As Integer
Dim ra As Range
Dim add2 As String
Dim add3 As String
Dim add4 As String
Dim add5 As String
Dim var As Integer
Dim add6 As String
Dim mypath As String
Dim ol As Integer
Dim firstcelladd As String
Dim firstcell As Range
Dim rl As Integer


Application.ScreenUpdating = False

''this is to get the activehseet name which i will match with the search workbook
filename = ActiveWorkbook.Name
wsname = ActiveSheet.Name

' this is to find "Cell Name" which is my column criteria
Set ra = Range("A1:F10").find(what:="Cell Name", lookat:=xlWhole)
add = ra.Address
add5 = Mid(add, 2, 1) & "1"
add2 = Mid(add, 2, 1) & "22000"

'first column and last row finding of current sheet where i want to extract data
firstcolumn = Range("A1:F10").find(what:="Cell Name", lookat:=xlWhole).Column
firstrow = Range("A1:F10").find(what:="Cell Name", lookat:=xlWhole).Row + 1
finalcolumn = Sheets(wsname).Range("GG2").End(xlToLeft).Column
finalrow = Sheets(wsname).Range(add2).End(xlUp).Row


'array diclaration where i will put my serch criteria and matched value
ReDim paraname1(1 To finalcolumn)
ReDim value(1 To 23000, 1 To finalcolumn)
ReDim cellnm1(1 To finalrow)
var = firstcolumn - 1

'this is for active sheet where i put my seche criteria for row and clumn value
For I = firstcolumn To finalcolumn

    'column criteria for search
    paraname1(I) = Cells(firstrow - 1, I).value


Next
    'row criteria
For j = firstrow To finalrow
    cellnm1(j) = Cells(j, firstcolumn).value

Next

''this is the workbook form where i want to get the value
Application.ScreenUpdating = False
mypath = "D:\Office Work\VBA Work\3G Radio Network Planning Data Template.xlsm"
Workbooks.Open filename:=mypath

Application.EnableEvents = False

''select the sheet form whcih i will get the data               
Workbooks("3G Radio Network Planning Data Template").Activate
Sheets(wsname).Select
Sheets(wsname).AutoFilterMode = False

''first row and finalrow selection
finalrow2 = Sheets(wsname).Range("A1000000").End(xlUp).Row
firstrow2 = Range("a1: i100").find(what:="Cell Name", lookat:=xlWhole).Row
fistcolumn2 = Range("a1: i100").find(what:="Cell Name", lookat:=xlWhole).Column

''serchrange selection 
add3 = Range("a1: i100").find(what:="Cell Name", lookat:=xlWhole).Address
add6 = Mid(add3, 2, 1) & "1"
add4 = Mid(add3, 2, 1) & finalrow2


For k = firstcolumn To finalcolumn

    " macth the row criteria form my active sheet to the sheet i want to get the value form''
    ol = 1
    columnnumber = Application.Match(paraname1(k),Sheets(wsname).Range("2:2"), 0)


For l = firstrow To finalrow

'macth the column value form my first active sheet to the sheet form where i want to get the value from
                Set firstcell = Range(add6, add4).find(what:=cellnm1(l), lookat:=xlWhole)
                rownumber = Range(add6, add4).find(what:=cellnm1(l), lookat:=xlWhole).Row

                firstcelladd = firstcell.Address

                On Error GoTo msg

                value(ol, k) = Cells(rownumber, columnnumber)

                ol = ol + 1
                Do

                Set firstcell = Range(add6, add4).FindNext(firstcell)
                rownumber = firstcell.Row

                If firstcell.Address <> firstcelladd Then

                value(ol, k) = Cells(rownumber, columnnumber)
                ol = ol + 1
                End If

                Loop Until firstcell.Address = firstcelladd







        Next


Next

ol = 1

'ActiveWorkbook.Close False


' select the previsus active workook aging where i wil paste the value
Workbooks(filename).Activate
Sheets(wsname).Select
Sheets(wsname).AutoFilterMode = False

For s = firstcolumn To finalcolumn

    rl = firstrow
    ol = 1

    Do
    Cells(rl, s) = value(ol, s)
    rl = rl + 1
    ol = ol + 1

    Loop While value(ol, s) <> ""




Next



Erase cellnm1

Erase paraname1

Erase value
Exit Sub
msg: MsgBox (" Cell Name " & cellnm1(l) & " not found")

End Sub

Answer 1

我想那是不可能的。要使用确定的过滤器等访问数据，即使通过ADO也需要将其打开。无论如何，由于不需要保存要从中复制数据的书籍，因此可以加快关闭速度。这是一部分。

其他部分，如果您要多次复制它，则可以将提取/转换/加载任务组织到以下位置：

开源书
创建目标图书文件
过滤源数据
将数据复制到目标书
保存目标书

在不关闭原始书的情况下，根据需要重复2-5点。这是您可以获得的最大数量。

另一部分是XLSX本身是一个ZIP存档，因此无论如何都要解压缩它。您还可以将这些文件保留在SSD驱动器上，或者附加虚拟RAM磁盘，这样也可以节省更多时间。

如何在不选择工作簿的情况下从匹配多个条件的封闭工作簿中提取数据？

1 个答案: