Macro collating data wrongly

[aaravgaba]

Hi Genius People,

I have the below code running for a sheet where I am collating data from various sheets.

The macro is running fine but the problems comes when it is pasting the values in the master sheet, where the last rows of the data are empty. Like in the below table the macro will paste po number till a3 but thereafter it will pick the PO number from the other sheet and will paste right under a3 thereby creating conflict in the table. I want that it should paste the data in each row relating to that very sheet. I know it is confusing but I am not able to attach the file to make it more specific. Thanks

Po number	part number	status	qty
a1	1234	packed	12
a2		picked
a3	1121		5
	1212	despatched	12
	43445	received	10
	3333	packed	5

<tbody>
</tbody>

Sub Get_Info_By_Headers()
    Dim sPath As String
    Dim sFil As String
    Dim owb As Workbook
    Dim twb As Workbook
    Dim ch
    Dim j As Long, a As Long
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    ch = Array("po number", "part number", "status", "quantity")
    Set twb = ThisWorkbook
    sPath = "C:\Users\dipak\Desktop\CRASH REPORT\"
    sFil = Dir(sPath & "*.xl*")
    Do While sFil <> "" And sFil <> twb.Name
        Set owb = Workbooks.Open(sPath & sFil)
            With owb.Sheets("data")
                For j = LBound(ch) To UBound(ch)
                    a = .Rows(1).Find(ch(j), , , 1).Column
                    .Range(.Cells(2, a), .Cells(.Cells(.Rows.Count, a).End(xlUp).Row, a)).Copy twb.Sheets("report").Cells(Rows.Count, j + 1).End(xlUp).Offset(1)
                Next j
            End With
        owb.Close False 'Close no save
        sFil = Dir
    Loop


    With Application
        .Calculation = xlAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

[JLGWhiz]

The macro copies the data in each column as it identified in the Find statement. As written, it would not paste anything in column A below the 'a3' entry because there is nothing in the source column below that entry. Can you describe what you want as a result, or post an illustration of it?

 

[aaravgaba]

Sorry i was not specific. I have many spreadsheets from where the data is taken. So what macro will do is to copy po number from another sheet and will paste po number right after a3 whereas it should leave the two empty cells to maintain the data integrity. So what happens is the final sheet depicts wrong po number against some other part number status and quantity. I want that it should paste the other sheet only after end of active cell of the sheet and not of the column only.

 

[aaravgaba]

I am reproducing the sheets in below table and the results i am getting and also the result i am anticipating.


first sheet

po number	part number	status	quantity
a1	1234	packed	12
a2		picked
a3	1121		5
	1212	despatched	12
	43445	received	10
	3333	packed	5

<tbody>
</tbody>

SECOND SHEET

po number	part number	status	quantity
aaaa	AARAV	PACKED
vvv	DEEPAK
ddd	C
eee	D	PACKED	5
		PACKED	5
ghhh		PACKED	5

<tbody>
</tbody>

THIRD SHEET

po number	part number	status	quantity
11	Z	RECEIVED	8
12	X	RECEIVED	8
13	C	RECEIVED	8
14	V	RECEIVED	8
15	G	RECEIVED	8
16	N	RECEIVED	8

<tbody>
</tbody>

RESULT I SHOULD GET AND I ANTICIPATE

Po number	part number	status	quantity
a1	1234	packed	12
a2		picked
a3	1121		5
	1212	despatched	12
	43445	received	10
	3333	packed	5
aaaa	AARAV	PACKED
vvv	DEEPAK	PACKED
ddd	C
eee	D		5
		PACKED	5
ghhh		PACKED	5
11	Z	RECEIVED	8
12	X	RECEIVED	8
13	C	RECEIVED	8
14	V	RECEIVED	8
15	G	RECEIVED	8
16	N	RECEIVED	8

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

RESULT I ACTUALLY GET

PO NUMBER	PART NUMBER	STATUS	QUANTITY
a1	1234	packed	12
a2		picked
a3	1121		5
aaaa	1212	despatched	12
vvv	43445	received	10
ddd	3333	packed	5
eee	AARAV	PACKED
	DEEPAK	PACKED
ghhh	C
11	D		5
12	Z	PACKED	5
13	X	PACKED	5
14	C	RECEIVED	8
15	V	RECEIVED	8
16	G	RECEIVED	8
	N	RECEIVED	8
		RECEIVED	8
		RECEIVED	8

<colgroup><col><col span="3"></colgroup><tbody>
</tbody>

Hope this will explain my problem. sorry to be a pain.

 

[JLGWhiz]

See is this mod will work for you.

Sub Get_Info_By_Headers2()
    Dim sPath As String
    Dim sFil As String
    Dim owb As Workbook
    Dim twb As Workbook
    Dim ch
    Dim j As Long, a As Long, lr As Long
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    ch = Array("po number", "part number", "status", "quantity")
    Set twb = ThisWorkbook
    sPath = "C:\Users\dipak\Desktop\CRASH REPORT\"
    sFil = Dir(sPath & "*.xl*")
    Do While sFil <> "" And sFil <> twb.Name
        Set owb = Workbooks.Open(sPath & sFil)
            With owb.Sheets("data")
                lr = twb.Sheets("report").Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
                For j = LBound(ch) To UBound(ch)                    
                    a = .Rows(1).Find(ch(j), , , 1).Column
                    .Range(.Cells(2, a), .Cells(.Cells(.Rows.Count, a).End(xlUp).Row, a)).Copy twb.Sheets("report").Cells(lr, j + 1)
                Next j
            End With
        owb.Close False 'Close no save
        sFil = Dir
    Loop
    With Application
        .Calculation = xlAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

[aaravgaba]

Salute to the true Genius. That worked like a charm.

Thanks a lot.

 

[JLGWhiz]

Salute to the true Genius. That worked like a charm.

Thanks a lot.

Glad you could use it,
regards, JLG

 

[aaravgaba]

Glad you could use it,
regards, JLG

Sorry for being greedy but is it possible if I want to include the name of the file from where the data is being taken to be included in one of the columns?

I feel you will definitely have the solution.

Thanks.

 

[aaravgaba]

Hi all

I was able to get the result (close to what I want not exact) by the following code.

Currently it is only putting the file name in bh2 to bh10. How can i make it put the file name in Bh2 to till the last active row of the sheet?

owb.Sheets("data").Range("bh2:bh10").Value = owb.Name

Sub Get_Info_By_Headers()
    Dim sPath As String
    Dim sFil As String
    Dim owb As Workbook
    Dim twb As Workbook
    Dim ch
    
    
    Dim j As Long, a As Long
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    ch = Array("po number", "part number", "status", "quantity", "project")
    Set twb = ThisWorkbook
    sPath = "C:\Users\dipak\Desktop\CRASH REPORT\"
    sFil = Dir(sPath & "*.xl*")
    Do While sFil <> "" And sFil <> twb.Name
        Set owb = Workbooks.Open(sPath & sFil)
            With owb.Sheets("data")
            owb.Sheets("DATA").Cells(1, 60) = "project"
            'owb.Sheets("DATA").Cells(2, 60) = owb.Name
            owb.Sheets("data").Range("bh2:bh10").Value = owb.Name
            
            
                lr = twb.Sheets("report").Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
                For j = LBound(ch) To UBound(ch)
                    a = .Rows(1).Find(ch(j), , , 1).Column
                    .Range(.Cells(2, a), .Cells(.Cells(.Rows.Count, a).End(xlUp).Row, a)).Copy twb.Sheets("report").Cells(lr, j + 1)
                    
                    Next j
            End With
        owb.Close False 'Close no save
        sFil = Dir
    Loop


    With Application
        .Calculation = xlAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub