VBA Code to Get data from the other sheet and sort it

[leprince2007]

Hello Everybody,
Could you help me in my question, please?
The file is about history of material in the store
The file contains a code that gets data from "Current Material" sheet and put it in "Report" Sheet and sort it.
But recently the code doesnot work well because the data is not organized ,run the code and go to the end of Report sheet.
Note:The code is called "Getpiles" in module 1
please help me

[PCI]

The macro is using column HB but today there is nothing inside this column.
Which column should be used ?

[leprince2007]

The code is called "Getpiles" in module 1 not macro1

[PCI]

To help can you explain what the code is doing, what is the final purpose ?

[leprince2007]

The file is about store history of piles (material ,company and its start and end).
"Current material" sheet:
ABC Columns are fixed and every 4 columns after it are repeated.
The code copies (ABC Columns & every 4 columns after it) from "Current Material" sheet to report sheet and then sort it by A column then f column.
for example:
1-ABC &DEFG
2-then ABC &HIJK
and so on
In order to see the code results,press run code button in "Report" sheet.The data in first rows are good but at the bottom of sheet aren`t.
please help me

[PCI]

See here new code.
Double check if the result is OK .. it is so different to the original one ...!

Sub Getpiles2()

Dim qt As Long, fil As Long, col1 As Long, x As Long, re As Long, lr As Long, llr As Long, mr As Range
Dim ColSt As Long, ColEnd As Long
Dim WkRg1 As Range, WkRg2 As Range
'Begin Optimize
    On Error GoTo enda:
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    'End Optimize
    
    ActiveSheet.UsedRange.Offset(1).Clear
    'Range("A1").CurrentRegion.Offset(1).Clear
    With Sheets("Current material")
        .Cells.UnMerge
        fil = 7
        qt = Application.CountIf(.Range("2:2"), "Finished Date") - 1
        .Range("A1").CurrentRegion.AutoFilter fil, Criteria1:="<>"
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        Set WkRg1 = .Range("A3:C" & lr)
        For x = 1 To qt
            ColSt = 4 + (x - 1) * 4
            ColEnd = ColSt + 3
            Set WkRg2 = Range(.Cells(3, ColSt), .Cells(lr, ColEnd))
            llr = Range("A" & Rows.Count).End(xlUp).Row + 1
            WkRg1.Copy Range("A" & llr)
            WkRg2.Copy Range("D" & llr)
        Next
    End With
    
    lr = Range("A" & Rows.Count).End(xlUp).Row
    Range("G1:G" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    Range("A1").CurrentRegion.Offset(2).Interior.Color = vbWhite
    lr = Range("A" & Rows.Count).End(xlUp).Row
    Set mr = ActiveSheet.Range("A2", "G" & lr)
    mr.Sort Key1:=Range("B2", "B" & lr), Order1:=xlAscending, key2:=Range("C2"), order2:=xlAscending, Header:=xlNo
    
    'Begin Optimize
enda:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    'End Optimize
    MsgBox "Job Done", vbExclamation, "INFORMATION"
    End Sub

[PCI]

A new code to reduce file size

Option Explicit


Sub Getpiles2()

Dim qt As Long, fil As Long, col1 As Long, x As Long, re As Long, lr As Long, llr As Long, mr As Range
Dim ColSt As Long, ColEnd As Long
Dim WkRg1 As Range, WkRg2 As Range
'Begin Optimize
    On Error GoTo enda:
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    'End Optimize
    
    ActiveSheet.UsedRange.Offset(1).Clear
    'Range("A1").CurrentRegion.Offset(1).Clear
    With Sheets("Current material")
        .Cells.UnMerge
        fil = 7
        qt = Application.CountIf(.Range("2:2"), "Finished Date") - 1
        .Range("A1").CurrentRegion.AutoFilter fil, Criteria1:="<>"
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        Set WkRg1 = .Range("A3:C" & lr)
        For x = 1 To qt
            ColSt = 4 + (x - 1) * 4
            ColEnd = ColSt + 3
            Set WkRg2 = Range(.Cells(3, ColSt), .Cells(lr, ColEnd))
            llr = Range("A" & Rows.Count).End(xlUp).Row + 1
            WkRg1.Copy Range("A" & llr)
            WkRg2.Copy Range("D" & llr)
        Next
    End With
    
    lr = Range("A" & Rows.Count).End(xlUp).Row
    Range("G1:G" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    ActiveSheet.UsedRange.Offset(1).Interior.Color = vbWhite
    lr = Range("A" & Rows.Count).End(xlUp).Row
    Set mr = ActiveSheet.Range("A2", "G" & lr)
    mr.Sort Key1:=Range("B2", "B" & lr), Order1:=xlAscending, key2:=Range("C2"), order2:=xlAscending, Header:=xlNo
    
    'Begin Optimize
enda:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    'End Optimize
    MsgBox "Job Done", vbExclamation, "INFORMATION"
    End Sub

[leprince2007]

The code works fine but the following line deletes empty rows and this result to reduce the range of any formula that depend on this sheet.

Range("G1:G" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Please I need to fix this problem

[leprince2007]

Please help
bump.....bump

[jindon]

1) if you want to copy/paste

Sub Getpiles()
    Dim rng As Range, r As Range, myArea As Range, LastR As Range
    Application.ScreenUpdating = False
    Set rng = Sheets("current material").Cells(1).CurrentRegion
    rng.Parent.AutoFilterMode = False
    Set myArea = rng.Rows(1).SpecialCells(2, 2)
    With Sheets("report")
        .[a3].CurrentRegion.Clear
        Set LastR = .[a3]
        For Each r In myArea
            If r <> "Errors" Then
                rng.AutoFilter r.Column, "<>"
                Union(rng.Offset(2).Columns("a:c"), rng.Offset(2).Columns(r.Column).Resize(, 4)).Copy LastR
                rng.AutoFilter
                Set LastR = .Range("a" & Rows.Count).End(xlUp)(2)
            End If
        Next
        .[a3].CurrentRegion.Sort .[b3], 1, , .[c3], 1
    End With
    Application.ScreenUpdating = True
End Sub

2) Using array

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, n As Long
    a = Sheets("current material").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 7)
    With Sheets("report")
        .[a3].CurrentRegion.ClearContents
        For i = 3 To UBound(a, 1)
            a(i, 1) = "'" & a(i, 1)
            For ii = 4 To UBound(a, 2) Step 4
                If a(i, ii) <> "" Then
                    n = n + 1
                    For iii = 1 To 3
                        b(n, iii) = a(i, iii)
                    Next
                    For iii = 4 To 7
                        b(n, iii) = a(i, ii + iii - 4)
                    Next
                End If
            Next
        Next
        .[a3].Resize(n, 7) = b
    End With
End Sub

[leprince2007]

Thanks jindon for your answer.
I prefer using arrays because they are faster but the code result contain repeated data:
the code should ignore last set of columns in "GN:GQ" from "Current material " sheet because they contain an equation to get last data in every pile.
Note: Columns "GN:GQ" are not fixed because I may add more columns before them. So I need the code to ignore last 4 columns only
thanks in advance

[jindon]

Add one line in bold

            a(i, 1) = "'" & a(i, 1)
            For ii = 4 To UBound(a, 2) Step 4
                If a(1, ii) = "Current" Then Exit For
                If a(i, ii) <> "" Then

[leprince2007]

Thanks jindon for your quick answer.but the code doesnot get the data in last row (pile "14-9") from "Current material" sheet
Please fix it
Thanks in advance

[jindon]

I've got one line of 14-9 at the bottom of result.

[leprince2007]

Sorry it works
thank you very much
Solved