VBA code that pulls the data from the workbook to another workbook

[MMM_84]

Looking for a VBA code that pulls the data from the workbook to another workbook based on several criteria. Not sure if that was already solved
Precisely, there is a "main" workbook, that contains a lot of information (column A to BN) and there is separate workbook with different worksheet names, matching the "main" workbook's column D data
Thus, I need a vba that copies from "main" workbook yellow marked information based on Green market matching criteria

Main workbook:

Book1.xlsx
	A	B	C	D	E	F	G	H	I
1	ID number	Reference	Period	Type	Comment	Criteria	etc.1	etc.2	etc.3
2	15645441	B2	06-05-99	Apple	Out of scope	ABC1
3	1545633	B2	07-05-99	Carrot	In Stock	ABC3
4	7863896	B3	08-05-99	Cucumber	Shortage	ABC4
5	741526	B4	09-05-99	Potato	Abundance	ABC5
6	896544	B5	10-05-99	Peach	Out of scope	ABC1
7	9865436	B6	11-05-99	Strawberry	In Stock	ABC2
8	68986546	B1	12-05-99	Blueberry	In Stock	ABC7
9	68986547	B2	13-05-99	Peach	Out of scope	ABC1
10	68986548	B3	14-05-99	Tomato	Out of scope	ABC3
11	68986549	B4	15-05-99	Apple	ABC	ABC4
12	68986550	B5	16-05-99	Carrot	Abundance	ABC5
13	68986551	B1	17-05-99	Apple	In Stock	ABC1
14	68986552	B3	18-05-99	Apple	In Stock	ABC2
15	68986553	B3	19-05-99	Potato	Abundance	ABC7
16	68986554	B4	20-05-99	Cucumber	Out of scope	ABC5
17	68986555	B5	21-05-99	Blueberry	Abundance	ABC4
main

The workbook and the "Apple" tab

Book1.xlsx
	A	B	C	D	E
1	Type	Apple
2	Reference	B1	B2	B3	B4
3	Criteria
4	ABC1	ID Number: 68986551 Period: 17-05-1999 Comment: In Stock	ID Number: 15645441 Period: 06-05-1999 Comment: Out of scope
5	ABC2			ID Number: 68986552 Period: 18-05-1999 Comment: In Stock
6	ABC3
7	ABC4				ID Number: 68986549 Period: 15-05-1999 Comment: ABC
8	ABC5
9	ABC6
10	ABC7
11	ABC8
12	ABC9
13	ABC10
Apple

 

[eiloken]

try this, i don't test it yet but you can and feddback to me:

Sub test()
    Dim shMain As Worksheet
    Dim desSh As Worksheet
    Dim Lr As Long
    Dim xRng As Range
    Dim xCll As Range
    Dim CriteriaRng As Range
    Dim RefRng As Range
    Dim desCll As Range
    Set shMain = ThisWorkbook.Sheets("main") 'this is sheet "main"
    Lr = shMain.Cells(Rows.Count, 1).End(xlUp).Row
    Set xRng = shMain.Range("A2:A" & Lr) 'this is ID Number range
    For Each xCll In xRng.Offset(, 3)  'loop each value in Type range
        If Not IsEmpty(xCll) Then
            Set desSh = ThisWorkbook.Sheets(xCll.Value) 'this sheet has same name as type so you have to make sure all your separate sheet have excatly name as each Type
            Set CriteriaRng = desSh.Range("A4:A99") 'this is criteria range in separate sheet, becase i don't know how many criteria in your main sheet so i set it to 99 criteria
            Set RefRng = desSh.Range("B2:AY2") 'this reference range i set to 50 reference same as above
            Set desCll = desSh.Range(CriteriaRng.Find(xCll.Offset(, 2)).Row, RefRng.Find(xCll.Offset(, -2)).Column) 'this is the cell need to find with match criteria and reference
            desCll.Value = "ID Number: " & xCll.Offset(, -3).Value & Chr(10) & _
            "Period: " & xCll.Offset(, -1).Value & Chr(10) & "Comment: " & xCll.Offset(, 1).Value 'this code get value from main sheet
        End If
    Next xCll
End Sub

 

[MMM_84]

try this, i don't test it yet but you can and feddback to me:

Sub test()
    Dim shMain As Worksheet
    Dim desSh As Worksheet
    Dim Lr As Long
    Dim xRng As Range
    Dim xCll As Range
    Dim CriteriaRng As Range
    Dim RefRng As Range
    Dim desCll As Range
    Set shMain = ThisWorkbook.Sheets("main") 'this is sheet "main"
    Lr = shMain.Cells(Rows.Count, 1).End(xlUp).Row
    Set xRng = shMain.Range("A2:A" & Lr) 'this is ID Number range
    For Each xCll In xRng.Offset(, 3)  'loop each value in Type range
        If Not IsEmpty(xCll) Then
            Set desSh = ThisWorkbook.Sheets(xCll.Value) 'this sheet has same name as type so you have to make sure all your separate sheet have excatly name as each Type
            Set CriteriaRng = desSh.Range("A4:A99") 'this is criteria range in separate sheet, becase i don't know how many criteria in your main sheet so i set it to 99 criteria
            Set RefRng = desSh.Range("B2:AY2") 'this reference range i set to 50 reference same as above
            Set desCll = desSh.Range(CriteriaRng.Find(xCll.Offset(, 2)).Row, RefRng.Find(xCll.Offset(, -2)).Column) 'this is the cell need to find with match criteria and reference
            desCll.Value = "ID Number: " & xCll.Offset(, -3).Value & Chr(10) & _
            "Period: " & xCll.Offset(, -1).Value & Chr(10) & "Comment: " & xCll.Offset(, 1).Value 'this code get value from main sheet
        End If
    Next xCll
End Sub

thanks, but I guess this works if all is in one workbook. In my case I have a main wb and the destination wb with different sheets such named after each type in main wb (such as sh "apple", "tomato" and etc.)

 

[eiloken]

thanks, but I guess this works if all is in one workbook. In my case I have a main wb and the destination wb with different sheets such named after each type in main wb (such as sh "apple", "tomato" and etc.)

So you can set destination workbook first and change destination worksheet like this:
Sub test()
Dim shMain As Worksheet
Dim desWb as workbook
Dim desSh As Worksheet
Dim Lr As Long
Dim xRng As Range
Dim xCll As Range
Dim CriteriaRng As Range
Dim RefRng As Range
Dim desCll As Range
Set desWb= getopenfilename("your destination workbook path")
Set shMain = ThisWorkbook.Sheets("main") 'this is sheet "main"
Lr = shMain.Cells(Rows.Count, 1).End(xlUp).Row
Set xRng = shMain.Range("A2:A" & Lr) 'this is ID Number range
For Each xCll In xRng.Offset(, 3) 'loop each value in Type range
If Not IsEmpty(xCll) Then
Set desSh = desWb.Sheets(xCll.Value) 'this sheet has same name as type so you have to make sure all your separate sheet have excatly name as each Type
Set CriteriaRng = desSh.Range("A4:A99") 'this is criteria range in separate sheet, becase i don't know how many criteria in your main sheet so i set it to 99 criteria
Set RefRng = desSh.Range("B2:AY2") 'this reference range i set to 50 reference same as above
Set desCll = desSh.Range(CriteriaRng.Find(xCll.Offset(, 2)).Row, RefRng.Find(xCll.Offset(, -2)).Column) 'this is the cell need to find with match criteria and reference
desCll.Value = "ID Number: " & xCll.Offset(, -3).Value & Chr(10) & _
"Period: " & xCll.Offset(, -1).Value & Chr(10) & "Comment: " & xCll.Offset(, 1).Value 'this code get value from main sheet
End If
Next xCll
End Sub

 

[eiloken]

So you can set destination workbook first and change destination worksheet like this:
Sub test()
Dim shMain As Worksheet
Dim desWb as workbook
Dim desSh As Worksheet
Dim Lr As Long
Dim xRng As Range
Dim xCll As Range
Dim CriteriaRng As Range
Dim RefRng As Range
Dim desCll As Range
Set desWb= getopenfilename("your destination workbook path")
Set shMain = ThisWorkbook.Sheets("main") 'this is sheet "main"
Lr = shMain.Cells(Rows.Count, 1).End(xlUp).Row
Set xRng = shMain.Range("A2:A" & Lr) 'this is ID Number range
For Each xCll In xRng.Offset(, 3) 'loop each value in Type range
If Not IsEmpty(xCll) Then
Set desSh = desWb.Sheets(xCll.Value) 'this sheet has same name as type so you have to make sure all your separate sheet have excatly name as each Type
Set CriteriaRng = desSh.Range("A4:A99") 'this is criteria range in separate sheet, becase i don't know how many criteria in your main sheet so i set it to 99 criteria
Set RefRng = desSh.Range("B2:AY2") 'this reference range i set to 50 reference same as above
Set desCll = desSh.Range(CriteriaRng.Find(xCll.Offset(, 2)).Row, RefRng.Find(xCll.Offset(, -2)).Column) 'this is the cell need to find with match criteria and reference
desCll.Value = "ID Number: " & xCll.Offset(, -3).Value & Chr(10) & _
"Period: " & xCll.Offset(, -1).Value & Chr(10) & "Comment: " & xCll.Offset(, 1).Value 'this code get value from main sheet
End If
Next xCll
End Sub

Because your separate workbook is all reference from your main workbook so i think set those in one wb will be more convenient, when you separate them, you need make sure your destination wb path not change or you should use file picker to pick it each time run macro, but when you just have 1 destination wb i think it will inconvenience

 

[MMM_84]

try this, i don't test it yet but you can and feddback to me:

Sub test()
    Dim shMain As Worksheet
    Dim desSh As Worksheet
    Dim Lr As Long
    Dim xRng As Range
    Dim xCll As Range
    Dim CriteriaRng As Range
    Dim RefRng As Range
    Dim desCll As Range
    Set shMain = ThisWorkbook.Sheets("main") 'this is sheet "main"
    Lr = shMain.Cells(Rows.Count, 1).End(xlUp).Row
    Set xRng = shMain.Range("A2:A" & Lr) 'this is ID Number range
    For Each xCll In xRng.Offset(, 3)  'loop each value in Type range
        If Not IsEmpty(xCll) Then
            Set desSh = ThisWorkbook.Sheets(xCll.Value) 'this sheet has same name as type so you have to make sure all your separate sheet have excatly name as each Type
            Set CriteriaRng = desSh.Range("A4:A99") 'this is criteria range in separate sheet, becase i don't know how many criteria in your main sheet so i set it to 99 criteria
            Set RefRng = desSh.Range("B2:AY2") 'this reference range i set to 50 reference same as above
            Set desCll = desSh.Range(CriteriaRng.Find(xCll.Offset(, 2)).Row, RefRng.Find(xCll.Offset(, -2)).Column) 'this is the cell need to find with match criteria and reference
            desCll.Value = "ID Number: " & xCll.Offset(, -3).Value & Chr(10) & _
            "Period: " & xCll.Offset(, -1).Value & Chr(10) & "Comment: " & xCll.Offset(, 1).Value 'this code get value from main sheet
        End If
    Next xCll
End Sub

I finally decided to have all in one wb, thus tried above one. Unfortunately, didn't work properly. Smth is wrong. Will try to understand what's exactly.....Thanks