• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Header wise consolidate sheets

A

Abhijeet

Active Member
Hi

i have macro that Headers wise paste data of all sheets please tell me all workbook how to pull data in to this macro
Code: 
Option Explicit
Sub CopyData()
Dim i As Integer, lastRow As Long
Dim PstRng As Range
Dim ws As Worksheet
Dim lrow As Long
Dim sht3 As Worksheet


Set sht3 = Worksheets("Macro Data")

sht3.[2:65536].EntireRow.Delete
For Each ws In Worksheets
    If ws.Name <> "Macro Data" Then
        ws.Select
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    lrow = sht3.Range("A" & Rows.Count).End(xlUp).Row
 
   
For i = 1 To 15
    Set PstRng = sht3.Range("1:1").Find(Cells(1, i).Value, [A1], xlValues, xlWhole)
    If Not PstRng Is Nothing Then
        Range(Cells(2, i), Cells(lastRow, i)).Copy PstRng.Offset(lrow, 0)
    End If
Next i
End If
Next ws
MsgBox "Done"
End Sub
 
Hello Abhijeet
I tested your code and it works well for me as it depends on the headers in "Macro Data" sheet and transfers proper data from proper headers in other sheets
What is your problem exactly?
It is always better to upload sample file with input and output to make your request as clear as sun
 
Hi

I want all files & sheets to consolidate as per headers mention Macro Data sheet
Please tell me how to loop each file & sheets
 
This type of all files & sheets Macro Data sheet i want to consolidate data for all files & sheets
 

Attachments

  • Headers wise paste all sheets.xlsm
    18.5 KB · Views: 5
Please help yourself by putting the desired results to be easy to get help from others as I can't get your language well .. may be it is my bad language
 
Code: 
Sub test()
    Dim ws As Worksheet, x
    With Sheets("macro data")
        .Cells(1).CurrentRegion.Offset(1).ClearContents
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                x = Filter(Application.IfError(Application.Match(.Rows(1), _
                ws.Cells(1).CurrentRegion.Rows(1), 0), Chr(2)), Chr(2), 0)
                If UBound(x) > -1 Then
                    With ws.Cells(1).CurrentRegion
                        With .Offset(1).Resize(.Rows.Count - 1)
                            x = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
                        End With
                    End With
                    With .Cells(1).CurrentRegion
                        .Rows(.Rows.Count + 1).Resize(UBound(x, 1)).Value = x
                    End With
                End If
            End If
        Next
    End With
End Sub
 
Thanks a lot Mr. Jindon for all the great help you offered here and there and everywhere ..
As for your code it gives the same results as the code provided in his example ..
So the same logic .. So what was the OP problem? I don't know exactly what was his problem was
 
Hi,YasserKhalil

I already mention this macro pull only consolidate the sheets i want from all workbooks data to be consolidate
 
If i change my data then this macro not work my previous macro work but this code not give correct result

jindon said:
Code: 
Sub test()
    Dim ws As Worksheet, x
    With Sheets("macro data")
        .Cells(1).CurrentRegion.Offset(1).ClearContents
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                x = Filter(Application.IfError(Application.Match(.Rows(1), _
                ws.Cells(1).CurrentRegion.Rows(1), 0), Chr(2)), Chr(2), 0)
                If UBound(x) > -1 Then
                    With ws.Cells(1).CurrentRegion
                        With .Offset(1).Resize(.Rows.Count - 1)
                            x = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
                        End With
                    End With
                    With .Cells(1).CurrentRegion
                        .Rows(.Rows.Count + 1).Resize(UBound(x, 1)).Value = x
                    End With
                End If
            End If
        Next
    End With
End Sub
Click to expand...
 

Attachments

  • Headers wise paste all sheets.xlsm
    21.9 KB · Views: 3
Such an unreal data setting.
Not worthy to even try...
Code: 
Sub test()
    Dim ws As Worksheet, x
    With Sheets("macro data")
        .Cells(1).CurrentRegion.Offset(1).ClearContents
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                x = Application.IfError(Application.Match(.Rows(1), _
                ws.UsedRange.Rows(1), 0), ws.Cells.SpecialCells(11).Column + 1)
                ReDim Preserve x(.Cells(1).CurrentRegion.Columns.Count - 1)
                If UBound(x) > -1 Then
                    With ws.UsedRange
                        With .Offset(1).Resize(.Rows.Count - 1)
                            x = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
                        End With
                    End With
                    With .Cells(1).CurrentRegion
                        .Rows(.Rows.Count + 1).Resize(UBound(x, 1)).Value = x
                    End With
                End If
            End If
        Next
    End With
End Sub
 
jindon said:
Such an unreal data setting.
Not worthy to even try...
Code: 
Sub test()
    Dim ws As Worksheet, x
    With Sheets("macro data")
        .Cells(1).CurrentRegion.Offset(1).ClearContents
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                x = Application.IfError(Application.Match(.Rows(1), _
                ws.UsedRange.Rows(1), 0), ws.Cells.SpecialCells(11).Column + 1)
                ReDim Preserve x(.Cells(1).CurrentRegion.Columns.Count - 1)
                If UBound(x) > -1 Then
                    With ws.UsedRange
                        With .Offset(1).Resize(.Rows.Count - 1)
                            x = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
                        End With
                    End With
                    With .Cells(1).CurrentRegion
                        .Rows(.Rows.Count + 1).Resize(UBound(x, 1)).Value = x
                    End With
                End If
            End If
        Next
    End With
End Sub
Click to expand...
This is work for single file all sheets
Can u please tell me how to consolidate all files data
 
Abhijeet said:
If i change my data then this macro not work my previous macro work but this code not give correct result
Click to expand...
If you have a working code, why you ask?
I said it is not even worthy for me to write a code for such unreal data setting.
It is not fun at all...
 
Hi Jindon

I mention this code is work for single file i need all files in folder to pull the data so please tell me how to loop files in this macro
 
Not tested.
Code: 
Sub CopyData()
   
    Dim i As Integer, lastRow As Long
    Dim PstRng As Range
    Dim ws As Worksheet
    Dim lrow As Long
    Dim sht3 As Worksheet
    Dim myDir As String, fn As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    Set sht3 = Worksheets("Macro Data")
    sht3.[2:65536].EntireRow.Delete
    fn = Dir(myDir & "*.xls*")
    Do While fn <> ""
        With Workbooks.Open(myDir & fn)
            For Each ws In .Sheets
                lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
                lrow = sht3.Range("A" & Rows.Count).End(xlUp).Row
     
       
                For i = 1 To 15
                    Set PstRng = sht3.Range("1:1").Find(ws.Cells(1, i).Value, [A1], xlValues, xlWhole)
                    If Not PstRng Is Nothing Then
                        ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i)).Copy PstRng.Offset(lrow, 0)
                    End If
                Next i
            Next
            .Close False
        End With
        fn = Dir
    Loop
    MsgBox "Done"
End Sub
 
jindon said:
Not tested.
Code: 
Sub CopyData()
  
    Dim i As Integer, lastRow As Long
    Dim PstRng As Range
    Dim ws As Worksheet
    Dim lrow As Long
    Dim sht3 As Worksheet
    Dim myDir As String, fn As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    Set sht3 = Worksheets("Macro Data")
    sht3.[2:65536].EntireRow.Delete
    fn = Dir(myDir & "*.xls*")
    Do While fn <> ""
        With Workbooks.Open(myDir & fn)
            For Each ws In .Sheets
                lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
                lrow = sht3.Range("A" & Rows.Count).End(xlUp).Row
    
      
                For i = 1 To 15
                    Set PstRng = sht3.Range("1:1").Find(ws.Cells(1, i).Value, [A1], xlValues, xlWhole)
                    If Not PstRng Is Nothing Then
                        ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i)).Copy PstRng.Offset(lrow, 0)
                    End If
                Next i
            Next
            .Close False
        End With
        fn = Dir
    Loop
    MsgBox "Done"
End Sub
Click to expand...
Its work thanks for ur great support
 
You must log in or register to reply here.
Back
Top