Мне нужно извлечь данные из одного большого Excel, соответствующего критериям строки и столбца.У меня большой Excel с 100 или листов и больше, чем 120 МБ.Мне нужно извлечь данные из этой рабочей книги в текущую рабочую книгу, соответствующую имени листа, критериям столбца и критериям строки.
У меня есть код, который может это сделать, но проблема в том, что каждый раз, когда я открываю книгу в фоновом режимеи закройте его, что занимает слишком много времени.Так как я могу это не открывать в фоновом режиме?Я читал о подключении 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