I need to extract data from one big Excel matching row and column criteria. I have big Excel with 100 or sheets and bigger than 120mb. I need to extract the data from that workbook to current workbook matching sheet name, column criteria and row criteria.

I have a code which can do that but the problem is if every time I open the workbook in the background and close it that takes too much time. So how can I it without opening it in the background? I have read about ADO connecting but I actually do not understand the code and also I don't understand about how can I do it with excel4macro.

I am including my code. I am new to coding so there will be lots of mistakes I guess. This is for my work purpose.

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

1 Answers

0
Community On

I guess it is impossible. To access data with definite filters and so on, you'll need to open it, even through ADO. Anyway, you can speed-up the closing, as you don't need to save book, from which you are copying data. That's one part.

Other part, if you are copying it many times, you can organize extract/transform/load task just in to:

  1. open source book
  2. create target book file
  3. filter source data
  4. copy data to target book
  5. save target book

Without closing source book repeat points 2-5 as much as needed. This is maximum you can get.

Other part is that XLSX itself is an ZIP archive, so it will take a plenty of time to decompress it anyway. You can also keep these files on SSD drive or attach virtual RAM disk maybe, this could save a bit more time also.