Filtering data depending on a specific column

[menajaro]

Hello everyone
I have this attachment that Transfer specific columns from one sheet into two sheets Depending on two condition in the column k in source sheet to sheets " main store & Another stores " It works very well....but I need to filter the data In both of the two sheets " main store & Another stores " Depending on the column L in source sheet, I tried to apply the solution but could not do that. Please see what I want to achieve in this example. I'd be grateful for some support.
I have posted the same thread at this link
https://www.excelforum.com/excel-progra ... ost5258664" onclick="window.open(this.href);return false;
Thank you

[HansV]

You haven't explained how or what you want to filter.

[menajaro]

Thanks a lot Mr. Hans
I need to transfer data to both sheets "main store & Another stores" if condition is met in column L I think I need to add another condition to achieve this
Thank you very much in advance.

[HansV]

But which condition in column L?

[menajaro]

The condition is ( the payment was made ) in column L in source sheet.

[HansV]

Why didn't you mention that in the first post?
Try this version:

Code: Select all

Sub VBAArrayTypeAlternativeToFilter()
    ' Worksheets
    Dim wS As Worksheet
    Dim wM As Worksheet
    Dim wA As Worksheet
    ' Range Info
    Dim m As Long
    Dim arrK As Variant
    ' Indices needed  for output arrays
    Dim strMain As String, strAnother As String
    Dim cnt As Long
    Dim clms As Variant
    Dim strRws() As String
    Dim Rws() As String
    Dim arrOut As Variant

    Set wS = Worksheets("Source")
    Set wM = Worksheets("Main Store")
    Set wA = Worksheets("Another Stores")

    m = wS.Range("A" & Rows.Count & "").End(xlUp).Row
    arrK = wS.Range("K1:L" & m).Value
    strMain = "7"
    strAnother = "7"
    For cnt = 8 To m
        If arrK(cnt, 2) Like "*payment was made" Then
            If arrK(cnt, 1) = "main store" Then
                strMain = strMain & " " & cnt
            Else
                strAnother = strAnother & " " & cnt
            End If
        End If
    Next cnt

    'Output Main Store
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strMain)
    ReDim Rws(1 To UBound(strRws) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt

    arrOut = Application.Index(wS.Cells, Rws, clms)
    With wM.Range("A13").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wM.Range("C13"), Header:=True
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
    End With

    'Output Another Stores
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strAnother)
    ReDim Rws(1 To UBound(strRws, 1) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws, 1) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
    arrOut = Application.Index(wS.Cells, Rws, clms)
    With wA.Range("A13").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wA.Range("C13"), Header:=True
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
    End With
End Sub

[menajaro]

In fact Mr Hans It is greater than I imagined. Thank you very very much for that Genius solution
I have three additions to adjust the two sheets " main store & Another stores ".
Please accept my apologies for these additions, but I tried However failed to achieve it.
Additions as follows:-
1- I need to be divided each 27 rows from the Start of row 19
2- add strings As the signatures of the officials like "Deputy Director / General Director"... below the tables.
3- Adjust page breaks.
Please see the attachment for a sample of the data and the desired output.
Have a nice time my Professor, Thank you in advance

[HansV]

See the attached version. I had to clear the Print Area of the Main Store and Another Stores sheets.

sample2222.xlsm

Code: Select all

Sub VBAArrayTypeAlternativeToFilter()
    ' Worksheets
    Dim wS As Worksheet
    Dim wM As Worksheet
    Dim wA As Worksheet
    ' Range Info
    Dim m As Long
    Dim arrK As Variant
    ' Indices needed  for output arrays
    Dim strMain As String, strAnother As String
    Dim cnt As Long
    Dim clms As Variant
    Dim strRws() As String
    Dim Rws() As String
    Dim arrOut As Variant
    Dim i As Long
    Dim r As Long
    Dim n As Long

    Set wS = Worksheets("Source")
    Set wM = Worksheets("Main Store")
    Set wA = Worksheets("Another Stores")

    m = wS.Range("A" & Rows.Count & "").End(xlUp).Row
    arrK = wS.Range("K1:L" & m).Value
    strMain = "7"
    strAnother = "7"
    For cnt = 8 To m
        If arrK(cnt, 2) Like "*payment was made" Then
            If arrK(cnt, 1) = "main store" Then
                strMain = strMain & " " & cnt
            Else
                strAnother = strAnother & " " & cnt
            End If
        End If
    Next cnt

    'Output Main Store
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strMain)
    ReDim Rws(1 To UBound(strRws) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt

    arrOut = Application.Index(wS.Cells, Rws, clms)
    wM.Activate
    wM.Range("19:" & wM.Rows.Count).Clear
    wM.Range("19:" & wA.Rows.Count).Delete
    m = UBound(arrOut, 1)
    With wM.Range("A18").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wM.Range("C18"), Header:=True
    End With
    For i = Application.Ceiling(m / 27, 1) To 1 Step -1
        r = 19 + 27 * i
        wM.Range("A" & r).EntireRow.Insert
        wM.Range("B" & r).Value = "Deputy Director"
        wM.Range("D" & r).Value = "General Director"
        wM.HPageBreaks.Add wM.Range("A" & r + 1)
    Next i
    n = wM.Range("B" & wM.Rows.Count).End(xlUp).Row
    With wM.Range("A18:E" & n)
        .Borders.LineStyle = xlContinuous
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
    End With

    'Output Another Stores
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strAnother)
    ReDim Rws(1 To UBound(strRws, 1) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws, 1) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
    arrOut = Application.Index(wS.Cells, Rws, clms)
    wA.Activate
    wA.Range("19:" & wA.Rows.Count).Delete
    m = UBound(arrOut, 1)
    With wA.Range("A18").Resize(m, UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wA.Range("C18"), Header:=True
    End With
    For i = Application.Ceiling(m / 27, 1) To 1 Step -1
        r = 19 + 27 * i
        wA.Range("A" & r).EntireRow.Insert
        wA.Range("B" & r).Value = "Deputy Director"
        wA.Range("D" & r).Value = "General Director"
        wA.HPageBreaks.Add wA.Range("A" & r + 1)
    Next i
    n = wA.Range("B" & wA.Rows.Count).End(xlUp).Row
    With wA.Range("A18:E" & n)
        .Borders.LineStyle = xlContinuous
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
    End With
End Sub

[menajaro]

Thank you Mr. Hans, for this great support
Please, we will need to adjust two points
The first point is : I need to add strings As the signatures of the officials below the tables, without border
The second point is : I tested the code on original data ( about 25000 rows ) and found it great and working very well but it took some time.
Is there any other additions to make it faster?
Thank you very much in advance.

[HansV]

What do you want to change for this? "I need to add strings As the signatures of the officials below the tables, without border"

[menajaro]

There is no change... but one row should be inserted between tables without borders... that's what I mean

[HansV]

Here is a new version. You'll have to live with the code being slow.

Code: Select all

Sub VBAArrayTypeAlternativeToFilter()
    ' Worksheets
    Dim wS As Worksheet
    Dim wM As Worksheet
    Dim wA As Worksheet
    ' Range Info
    Dim m As Long
    Dim arrK As Variant
    ' Indices needed  for output arrays
    Dim strMain As String, strAnother As String
    Dim cnt As Long
    Dim clms As Variant
    Dim strRws() As String
    Dim Rws() As String
    Dim arrOut As Variant
    Dim i As Long
    Dim r As Long
    Dim n As Long

    Set wS = Worksheets("Source")
    Set wM = Worksheets("Main Store")
    Set wA = Worksheets("Another Stores")

    m = wS.Range("A" & Rows.Count & "").End(xlUp).Row
    arrK = wS.Range("K1:L" & m).Value
    strMain = "7"
    strAnother = "7"
    For cnt = 8 To m
        If arrK(cnt, 2) Like "*payment was made" Then
            If arrK(cnt, 1) = "main store" Then
                strMain = strMain & " " & cnt
            Else
                strAnother = strAnother & " " & cnt
            End If
        End If
    Next cnt

    'Output Main Store
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strMain)
    ReDim Rws(1 To UBound(strRws) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
    arrOut = Application.Index(wS.Cells, Rws, clms)
    wM.Activate
    wM.Range("19:" & wM.Rows.Count).Clear
    wM.Range("19:" & wM.Rows.Count).Delete
    m = UBound(arrOut, 1)
    With wM.Range("A18").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wM.Range("C18"), Header:=True
        .Borders.LineStyle = xlContinuous
    End With
    For i = Application.Ceiling(m / 27, 1) To 1 Step -1
        r = 19 + 27 * i
        wM.Range("A" & r).EntireRow.Insert
        wM.Range("A" & r).Resize(1, 5).Borders(xlInsideVertical).LineStyle = xlLineStyleNone
        wM.Range("B" & r).Value = "Deputy Director"
        wM.Range("D" & r).Value = "General Director"
        wM.HPageBreaks.Add wM.Range("A" & r + 1)
    Next i
    n = wM.Range("B" & wM.Rows.Count).End(xlUp).Row
    With wM.Range("A18:E" & n)
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
    End With

    'Output Another Stores
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strAnother)
    ReDim Rws(1 To UBound(strRws, 1) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws, 1) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
    arrOut = Application.Index(wS.Cells, Rws, clms)
    wA.Activate
    wA.Range("19:" & wM.Rows.Count).Clear
    wA.Range("19:" & wM.Rows.Count).Delete
    m = UBound(arrOut, 1)
    With wA.Range("A18").Resize(m, UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wA.Range("C18"), Header:=True
        .Borders.LineStyle = xlContinuous
    End With
    For i = Application.Ceiling(m / 27, 1) To 1 Step -1
        r = 19 + 27 * i
        wA.Range("A" & r).EntireRow.Insert
        wM.Range("A" & r).Resize(1, 5).Borders(xlInsideVertical).LineStyle = xlLineStyleNone
        wA.Range("B" & r).Value = "Deputy Director"
        wA.Range("D" & r).Value = "General Director"
        wA.HPageBreaks.Add wA.Range("A" & r + 1)
    Next i
    n = wA.Range("B" & wA.Rows.Count).End(xlUp).Row
    With wA.Range("A18:E" & n)
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
    End With
End Sub

[menajaro]

Thanks a lot Mr. Hans for your patience in solving that issue
Same problem in this line of code

Code: Select all

 wM.Range("A" & r).Resize(1, 5).Borders(xlInsideVertical).LineStyle = xlLineStyleNone

I will explain in another way
the previous page ends with border and the following page starts with border while this inserted row left without borders.
How can this line be modified... Thank you so much for all your assistance!

[HansV]

Please explain what you actually want. It's not clear to me yet.

[menajaro]

Thank you very much Mr. Hans
Everything is okay except for one point, I want to be able to insert empty row without borders after each 27 rows to add some Text strings
like "Deputy Director / General Director"... below the tables ( it has already been done )
With a note. if there is remain for example 4, then to put borders to suit the 27 records and let other 23 records empty but with the borders existing
Hope it is clear. Thank you so much for all your assistance!

[HansV]

But the inserted row doesn't have borders between the cells...

[menajaro]

Yes sir, but only on the first page of a sheet "main store" As for the sheet other stores, nothing.
Please note the yellow rows in this example,Thank you in advance again

[HansV]

The macro in your sample workbook is not the most recent one that I posted! But here is yet another version:

Code: Select all

Sub VBAArrayTypeAlternativeToFilter()
    ' Worksheets
    Dim wS As Worksheet
    Dim wM As Worksheet
    Dim wA As Worksheet
    ' Range Info
    Dim m As Long
    Dim arrK As Variant
    ' Indices needed  for output arrays
    Dim strMain As String, strAnother As String
    Dim cnt As Long
    Dim clms As Variant
    Dim strRws() As String
    Dim Rws() As String
    Dim arrOut As Variant
    Dim i As Long
    Dim r As Long
    Dim n As Long
    Dim c As Range
    Dim a As String

    Set wS = Worksheets("Source")
    Set wM = Worksheets("Main Store")
    Set wA = Worksheets("Another Stores")

    m = wS.Range("A" & Rows.Count & "").End(xlUp).Row
    arrK = wS.Range("K1:L" & m).Value
    strMain = "7"
    strAnother = "7"
    For cnt = 8 To m
        If arrK(cnt, 2) Like "*payment was made" Then
            If arrK(cnt, 1) = "main store" Then
                strMain = strMain & " " & cnt
            Else
                strAnother = strAnother & " " & cnt
            End If
        End If
    Next cnt

    'Output Main Store
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strMain)
    ReDim Rws(1 To UBound(strRws) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
    arrOut = Application.Index(wS.Cells, Rws, clms)
    wM.Activate
    wM.Range("19:" & wM.Rows.Count).Clear
    wM.Range("19:" & wM.Rows.Count).Delete
    m = UBound(arrOut, 1)
    With wM.Range("A18").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wM.Range("C18"), Header:=True
    End With
    For i = Application.Ceiling(m / 27, 1) To 1 Step -1
        r = 19 + 27 * i
        wM.Range("A" & r).EntireRow.Insert
        wM.Range("B" & r).Value = "Deputy Director"
        wM.Range("D" & r).Value = "General Director"
        wM.HPageBreaks.Add wM.Range("A" & r + 1)
    Next i
    n = wM.Range("B" & wM.Rows.Count).End(xlUp).Row
    With wM.Range("A18:E" & n)
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
        .Borders.LineStyle = xlContinuous
    End With
    With wM.Range("B18:B" & n)
        Set c = .Find(What:="Deputy Director", LookAt:=xlWhole)
        If Not c Is Nothing Then
            a = c.Address
            Do
                With c.Offset(0, -1).Resize(1, 5)
                    .Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
                    .Borders(xlInsideVertical).LineStyle = xlLineStyleNone
                    .Borders(xlEdgeRight).LineStyle = xlLineStyleNone
                End With
                Set c = .FindNext(After:=c)
            Loop Until c.Address = a
        End If
    End With

    'Output Another Stores
    clms = Array(1, 4, 6, 13, 14)
    strRws = Split(strAnother)
    ReDim Rws(1 To UBound(strRws, 1) + 1, 1 To 1)
    For cnt = 1 To UBound(strRws, 1) + 1
        Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
    arrOut = Application.Index(wS.Cells, Rws, clms)
    wA.Activate
    wA.Range("19:" & wM.Rows.Count).Clear
    wA.Range("19:" & wM.Rows.Count).Delete
    m = UBound(arrOut, 1)
    With wA.Range("A18").Resize(m, UBound(arrOut, 2))
        .Value = arrOut
        .Sort Key1:=wA.Range("C18"), Header:=True
    End With
    For i = Application.Ceiling(m / 27, 1) To 1 Step -1
        r = 19 + 27 * i
        wA.Range("A" & r).EntireRow.Insert
        wA.Range("B" & r).Value = "Deputy Director"
        wA.Range("D" & r).Value = "General Director"
        wA.HPageBreaks.Add wA.Range("A" & r + 1)
    Next i
    n = wA.Range("B" & wA.Rows.Count).End(xlUp).Row
    With wA.Range("A18:E" & n)
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .RowHeight = 17
        .Borders.LineStyle = xlContinuous
    End With
    With wA.Range("B18:B" & n)
        Set c = .Find(What:="Deputy Director", LookAt:=xlWhole)
        If Not c Is Nothing Then
            a = c.Address
            Do
                With c.Offset(0, -1).Resize(1, 5)
                    .Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
                    .Borders(xlInsideVertical).LineStyle = xlLineStyleNone
                    .Borders(xlEdgeRight).LineStyle = xlLineStyleNone
                End With
                Set c = .FindNext(After:=c)
            Loop Until c.Address = a
        End If
    End With
End Sub

[menajaro]

Thanks a lot Mr. Hans for this great solution .. It works perfectly
Best Regards

[menajaro]

I am so sorry Mr. Hans for disturbing you again in this topic ..
With clear the Print Area of the Main Store and Another Stores sheets … The borders of the following pages appear below the signatures.
Is there any additional lines to set the print area Below these two lines of code.

Code: Select all

wM.HPageBreaks.Add wM.Range("A" & r + 1)

Code: Select all

wA.HPageBreaks.Add wA.Range("A" & r + 1)

Thanks again for all your help