extracting data from closed workbook

hello,

I have to make a excel table every week which contains data that made by our several stations in factory in everyday. so when friday comes nightmare starts for me and weekend as well(like today ). actually I have to da a simple table but there are lots of data so i couldnt handle with it.

I ll try to explain my situation with my horrible english

I have 2 excel files. One of them is data excel(close) and one of them is open excel which i have to make a table. In our factory we have several station and several processes, I try to explain with an example I have attached the 2 files demo(simple ver.)

In closed file close.xlsx in "Main" Sheet Starts with "F2" cell and continious to horizontal(G3,H3,I3 . . . ) are model numbers and there are "0" and "1" values below that model numbers For ex. in closed file main sheet F2 cell "1xxx" model number and "F3" cell value is "1" so that i have to get data A3,B3,C3,D3,E3 to my open excel Open.xlsx / when i put the model number of "1xxx" to "A3" cell in open.xlsx or when I started the macro or fonction or etc it will automaticly fill B3,C3,D3,E3,F3 in open.xlsx with the data of close.xlsx.

I hope i can explain my problem simply and waiting a very good favor that i ll not forget years and years.

BR
close.xlsxopen.xlsx

Dear Naveed Raza Ty for reply

I need all data from close workbook as by model by model if the value of cell which is under model number is "1".

Si is the ultimate aim to get the data from Columns A-E from the Close.xlsx file(Main sheet) for each Model number that has a "1" in its column?

You have a fairly small data sample there.. perhaps to make it clear to everyone what you want.. you should manually fill in the what you expect the result to be in the Open.xlsx workbook..

Ok i have filled open.xlsx "main" Sheet as it would be like taking data from close.xlsx "main" sheet.

I have to do it for all sheets and model numbers that in "data workbook", workbook have lots of sheets and some of the sheets have more then 50 model numbers but some of them are less like in ex.

Looking forward to hear from you.

Sark

open.xlsxclose.xlsx

Hi..

Try this..

I have attached the Workbook with code and also the Closed workbook i used for testing..

Click the Button.. select the Closed Workbook.. results shown in Main sheet of open workbook..

Private Sub CommandButton1_Click()
    Dim x, y, strFile As String, i As Long, ii As Long, iii As Long, j As Long, LR As Long, LC As Long
    Dim ws As Worksheet, wb As Workbook
    Application.DisplayAlerts = False

    'User Selects desired File
    strFile = Application.GetOpenFilename("Excel Files,*.xls*")
    If strFile = "False" Then Exit Sub

    'Open (in background) the Workbook
    Set wb = GetObject(strFile)
    With GetObject(strFile)
        For Each ws In wb.Sheets
            LC = .Sheets(ws.Name).Range("IV2").End(xlToLeft).Column
            LR = .Sheets(ws.Name).Range("Q" & Rows.Count).End(xlUp).Row

            x = .Sheets(ws.Name).Range(.Sheets(ws.Name).Cells(2, 1), .Sheets(ws.Name).Cells(LR, LC))
            ReDim y(Application.CountIfs(.Sheets(ws.Name).Range(.Sheets(ws.Name).Cells(3, 6), .Sheets(ws.Name).Cells(LR, LC)), "1") - 1, 1 To 6)

            'Build New Array
            For i = 6 To .Sheets(ws.Name).Range("IV2").End(xlToLeft).Column
                y(j, 1) = Application.Index(x, 1, i)
                For ii = 2 To UBound(x)
                    If x(ii, i) = "1" Then
                        For iii = 2 To 6
                            y(j, iii) = x(ii, iii - 1)
                        Next iii
                        j = j + 1
                    End If
                Next ii
            Next i
            
            ' Write new array to sheet
            Sheets("Main").Range("A" & Sheets("Main").Range("B" & Rows.Count).End(xlUp).Row).Offset(1).Resize(UBound(y) + 1, 6).Value = y
            j = 0
        Next ws
        .Close
    End With
Cleanup:
    Set fldr = Nothing
    Application.DisplayAlerts = True
End Sub

Hi..

Did it work the way you wanted in the workbooks i attached as examples?

If so.. then there is probably some minor adjustment needed..

Right now.. I am having slight trouble understanding your post.. but don't worry.. I am quite sure your English is 100 x better than my Turkish..

I will look tomorrow, absent the wine in my belly..

ty

It works excelent in some sheets and get data. but first i have made a mistake, in some sheets there aren't only "1" and "0" values data below model numbers. there are also "2", "3", "4", "5" values in these cells. so we have to look data values which is below of model numbers must be different from "0" instead of looking value is "1" and also we need this value in open.xlsx. for example the value is "2" then it will be like below.

25 Yan Duvarlara Travers Montajı(ÖN) ANA GÖVDE TOPLAMA 20 23+24 2

Just a couple of minor changes required..

This works for me..

Private Sub CommandButton1_Click()
    Dim x, y, strFile As String, i As Long, ii As Long, iii As Long, j As Long, LR As Long, LC As Long
    Dim ws As Worksheet, wb As Workbook
    Application.DisplayAlerts = False

    'User Selects desired File
    strFile = Application.GetOpenFilename("Excel Files,*.xls*")
    If strFile = "False" Then Exit Sub

    'Open (in background) the Workbook
    Set wb = GetObject(strFile)
    With GetObject(strFile)
        For Each ws In wb.Sheets
            LC = .Sheets(ws.Name).Range("IV2").End(xlToLeft).Column
            LR = .Sheets(ws.Name).Range("Q" & Rows.Count).End(xlUp).Row

            x = .Sheets(ws.Name).Range(.Sheets(ws.Name).Cells(2, 1), .Sheets(ws.Name).Cells(LR, LC))
            ReDim y(Application.CountIfs(.Sheets(ws.Name).Range(.Sheets(ws.Name).Cells(3, 6), .Sheets(ws.Name).Cells(LR, LC)), "<>0") - 1, 1 To 7)

            'Build New Array
            For i = 6 To .Sheets(ws.Name).Range("IV2").End(xlToLeft).Column
                y(j, 1) = Application.Index(x, 1, i)
                For ii = 2 To UBound(x)
                    If x(ii, i) <> "0" Then
                        For iii = 2 To 6
                            y(j, iii) = x(ii, iii - 1)
                        Next iii
                        y(j, 7) = x(ii, i)
                        j = j + 1
                    End If
                Next ii
            Next i
            
            ' Write new array to sheet
            Sheets("Main").Range("A" & Sheets("Main").Range("B" & Rows.Count).End(xlUp).Row).Offset(1).Resize(UBound(y) + 1, 7).Value = y
            j = 0
        Next ws
        .Close
    End With
Cleanup:
    Set fldr = Nothing
    Application.DisplayAlerts = True
End Sub

Thanks a lot, this is exactly! what i want

But only one file I couldnt get data from this (ÜST TABLA GRUBU.XLSX) excel file.(which attc. on my previous post) I dont know what I am doing wrong.

did you try on this file?

Hi..

Not sure.. if i hard code a value of 611 (which is the last used column).. instead of using:

.Sheets(ws.Name).Range("IV2").End(xlToLeft).Column

in the 2 place sit is used.. the results come fine..

Seems there is an issue with finding the last used column (in row 2).. I'll have to think on it..

Here you go.. this works on that Workbook as well..

Just uses a different method to find the last used column..

Private Sub CommandButton1_Click()
    Dim x, y, strFile As String, i As Long, ii As Long, iii As Long, j As Long, LR As Long, LC As Long
    Dim ws As Worksheet, wb As Workbook
    Application.DisplayAlerts = False

    'User Selects desired File
    strFile = Application.GetOpenFilename("Excel Files,*.xls*")
    If strFile = "False" Then Exit Sub

    'Open (in background) the Workbook
    Set wb = GetObject(strFile)
    With GetObject(strFile)
        For Each ws In wb.Sheets
            LC = .Sheets(ws.Name).Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
            LR = .Sheets(ws.Name).Range("Q" & Rows.Count).End(xlUp).Row

            x = .Sheets(ws.Name).Range(.Sheets(ws.Name).Cells(2, 1), .Sheets(ws.Name).Cells(LR, LC))
            ReDim y(Application.CountIfs(.Sheets(ws.Name).Range(.Sheets(ws.Name).Cells(3, 6), .Sheets(ws.Name).Cells(LR, LC)), "<>0") - 1, 1 To 7)

            'Build New Array
            For i = 6 To LC
                y(j, 1) = Application.Index(x, 1, i)
                For ii = 2 To UBound(x)
                    If x(ii, i) <> "0" Then
                        For iii = 2 To 6
                            y(j, iii) = x(ii, iii - 1)
                        Next iii
                        y(j, 7) = x(ii, i)
                        j = j + 1
                    End If
                Next ii
            Next i
            
            ' Write new array to sheet
            Sheets("Main").Range("A" & Sheets("Main").Range("B" & Rows.Count).End(xlUp).Row).Offset(1).Resize(UBound(y) + 1, 7).Value = y
            j = 0
        Next ws
        .Close
    End With
Cleanup:
    Set fldr = Nothing
    Application.DisplayAlerts = True
End Sub

Thanks Alot it works great!

I'll not forget this favour.

Best Regards,

No worries.. happy to help..

hello I need a help again, :/

Thus I dont want to start a new topic, I ll go with this one. Again I have 2 excel files. 1st one is data file 2nd one is workbook. workbook have 140.483 cells which starts "B2-B140483 "to match with data file "A3-A3131"cell. When the cells match then i need to get data from 1st file shown below A3(1st data)-(2nd workbook)B443,B722,.....

B3 C3 D3 E3 F3 G3 H3 I3 J3
B4 C4 D4 E4 F4 G4 H4 I4 J4
B5 C5 D5 E5 F5 G5 H5 I5 J5
B6 C6 D6 E6 F6 G6 H6 I6 J6
B7 C7 D7 E7 F7 G7 H7 I7 J7

for ex. it matches with "B443" "B722" and 12 more cells in workbook then copy data to

D443 E443 F443 G443 H443 I443 J443 K443 L443
D444 E444 F444 G444 H444 I444 J444 K444 L444
D445 E445 F445 G445 H445 I445 J445 K445 L445
D446 E446 F446 G446 H446 I446 J446 K446 L446
D447 E447 F447 G447 H447 I447 J447 K447 L447


-----

D722 E722 F722 G722 H722 I722 J722 K722 L722
D723 E723 F723 G723 H723 I723 J723 K723 L723
D724 E724 F724 G724 H724 I724 J724 K724 L724
D725 E725 F725 G725 H725 I725 J725 K725 L725
D726 E726 F726 G726 H726 I726 J726 K726 L726


and continious 10 more because "in workbook there are lots of same cells but in data file there is only one cell to be match."

I have filled an example file

1.xlsx2.xlsx

I would like to hear about solution for this issue.

Sark

ok.. Does this sum up what you want to do?

1. Loop through all the values in Column A (from A3 down) in 1.xlsx.

2. Then.. loop through all the values in Column B (from B2 down) in 2.xlsx and if it finds a Match.. then copy the contents from 1.xlsx (from Column D to Column L) to the 2.xlsx Workbook for each match it finds.

Yes exactly but it s hard to do for me IF it match A3 for example next value is A9 i need to get cells D3-L3 to D8-L8. The row size always changes so i have add extra rows in 2.xlsx to one value to other one in column B.