Stack multi columns in one column for visible cells only

S

shafiey

Board Regular
Joined
Sep 6, 2023
Messages
60
Office Version
  1. 365
Platform
  1. Windows

Why doesn't the formula work in column B when I change the range from A2:A1012 to A2:A2100?​

Formula in B2:
=IFERROR(SORT(FILTERXML("<t><s>" & SUBSTITUTE(TEXTJOIN("، ",,IF(SUBTOTAL(103,OFFSET(A2,ROW(A2:A1012)-ROW(A2),)),A2:A1012,"")),"، ","</s><s>") & "</s></t>","//s")),"")
Click to expand...

Formula in C2:
=IFERROR(SORT(FILTERXML("<t><s>" & SUBSTITUTE(TEXTJOIN("، ",,IF(SUBTOTAL(103,OFFSET(A2,ROW(A2:A2100)-ROW(A2),)),A2:A2100,"")),"، ","</s><s>") & "</s></t>","//s")),"")
Click to expand...

Why doesn't the formula work in column B when I change the range from A2:A1012 to A2:A2100?

My File

Thank you very much
 
Sort by date Sort by votes
Put this in a standard module

VBA Code: 
Sub Filter_Country(Country As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(Country) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AF").End(xlUp).Row).AutoFilter Field:=32, Criteria1:=Country
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("keywords").Activate
End Sub

Put this in the 'Keywords Analysis' worksheet's module
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then Filter_Country Range("D1").Value
End Sub

Now try changing the value in D1 of 'Keywords Analysis'
 
Upvote 0

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Peter_SSs said:
Put this in a standard module

VBA Code: 
Sub Filter_Country(Country As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(Country) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AF").End(xlUp).Row).AutoFilter Field:=32, Criteria1:=Country
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("keywords").Activate
End Sub

Put this in the 'Keywords Analysis' worksheet's module
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then Filter_Country Range("D1").Value
End Sub

Now try changing the value in D1 of 'Keywords Analysis'
Click to expand...
Thanks for your great tips.
How can I merge these two VBA codes?

1- Following code is related to multiple selection in a drop-down menu without repeating the selection:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 2019/11/13
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If Not Application.Intersect(Target, xRng) Is Nothing Then
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 <> "" Then
            If xValue2 <> "" Then
                If xValue1 = xValue2 Or _
                   InStr(1, xValue1, "¡ " & xValue2) Or _
                   InStr(1, xValue1, xValue2 & ",") Then
                    Target.Value = xValue1
                Else
                    Target.Value = xValue1 & "¡ " & xValue2
                End If
            End If
        End If
    End If
    Application.EnableEvents = True
End Sub

2- This code is also related to the filter that you took the trouble to write for me, and I manipulated it to apply 3 filters on 3 columns of data.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then Filter_namebakhsh Range("D1").Value

  If Not Intersect(Target, Range("F1")) Is Nothing Then Filter_saleshoroo Range("F1").Value

  If Not Intersect(Target, Range("H1")) Is Nothing Then Filter_salekhatameh Range("H1").Value

End Sub

The relevant codes in the module are as follows:

VBA Code: 
Sub Filter_namebakhsh(namebakhsh As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(namebakhsh) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AC").End(xlUp).Row).AutoFilter Field:=29, Criteria1:=namebakhsh
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("Keywords Analysis").Activate
  ActiveSheet.PivotTables("PivotTable2").RefreshTable
End Sub

Sub Filter_saleshoroo(saleshoroo As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(saleshoroo) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AF").End(xlUp).Row).AutoFilter Field:=32, Criteria1:=">=" & saleshoroo
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("Keywords Analysis").Activate
  ActiveSheet.PivotTables("PivotTable2").RefreshTable
End Sub

Sub Filter_salekhatameh(salekhatameh As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(salekhatameh) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AG").End(xlUp).Row).AutoFilter Field:=33, Criteria1:="<=" & salekhatameh
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("Keywords Analysis").Activate
  ActiveSheet.PivotTables("PivotTable2").RefreshTable
End Sub


thank you
 
Last edited:
Upvote 0
shafiey said:
Thanks for your great tips.
How can I merge these two VBA codes?

1- Following code is related to multiple selection in a drop-down menu without repeating the selection:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 2019/11/13
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If Not Application.Intersect(Target, xRng) Is Nothing Then
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 <> "" Then
            If xValue2 <> "" Then
                If xValue1 = xValue2 Or _
                   InStr(1, xValue1, "¡ " & xValue2) Or _
                   InStr(1, xValue1, xValue2 & ",") Then
                    Target.Value = xValue1
                Else
                    Target.Value = xValue1 & "¡ " & xValue2
                End If
            End If
        End If
    End If
    Application.EnableEvents = True
End Sub

2- This code is also related to the filter that you took the trouble to write for me, and I manipulated it to apply 3 filters on 3 columns of data.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then Filter_namebakhsh Range("D1").Value

  If Not Intersect(Target, Range("F1")) Is Nothing Then Filter_saleshoroo Range("F1").Value

  If Not Intersect(Target, Range("H1")) Is Nothing Then Filter_salekhatameh Range("H1").Value

End Sub

The relevant codes in the module are as follows:

VBA Code: 
Sub Filter_namebakhsh(namebakhsh As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(namebakhsh) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AC").End(xlUp).Row).AutoFilter Field:=29, Criteria1:=namebakhsh
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("Keywords Analysis").Activate
  ActiveSheet.PivotTables("PivotTable2").RefreshTable
End Sub

Sub Filter_saleshoroo(saleshoroo As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(saleshoroo) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AF").End(xlUp).Row).AutoFilter Field:=32, Criteria1:=">=" & saleshoroo
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("Keywords Analysis").Activate
  ActiveSheet.PivotTables("PivotTable2").RefreshTable
End Sub

Sub Filter_salekhatameh(salekhatameh As String)
  Application.Calculation = xlCalculationManual
  With Worksheets("Projects")
    .AutoFilterMode = False
    If Len(salekhatameh) > 0 Then .Range("A1:AQ" & .Cells(.Rows.Count, "AG").End(xlUp).Row).AutoFilter Field:=33, Criteria1:="<=" & salekhatameh
  End With
  Application.Calculation = xlCalculationAutomatic
  Worksheets("Keywords Analysis").Activate
  ActiveSheet.PivotTables("PivotTable2").RefreshTable
End Sub


thank you
Click to expand...
Oh I forgot, I have 3 dropdown lists in a sheet and I want only one of them to be multiselect and the others not. Please also correct the code posted above (No.1), very very very thanks.
 
Upvote 0
shafiey said:
Oh I forgot, I have 3 dropdown lists in a sheet and I want only one of them to be multiselect and the others not. Please also correct the code posted above (No.1), very very very thanks.
Click to expand...
I got the drop down multiple select code from another site and it solved the post 63 problem.
Please merge the following two codes for me:

Code 01:

VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
 
If Destination.Count > 1 Then Exit Sub
 
On Error Resume Next
Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError
 
If rngDropdown Is Nothing Then GoTo exitError

If Not Destination.Column = 4 Then GoTo exitError

If Intersect(Destination, rngDropdown) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newValue = Destination.Value
  Application.Undo
  oldValue = Destination.Value
  Destination.Value = newValue
    If oldValue <> "" Then
    If newValue <> "" Then
        If oldValue = newValue Or _
            InStr(1, oldValue, DelimiterType & newValue) Or _
            InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
            Destination.Value = oldValue
                Else
            Destination.Value = oldValue & DelimiterType & newValue
        End If
    End If
    End If
End If
 
exitError:
  Application.EnableEvents = True
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
End Sub

Code 02:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then Filter_namebakhsh Range("D1").Value

  If Not Intersect(Target, Range("F1")) Is Nothing Then Filter_saleshoroo Range("F1").Value

  If Not Intersect(Target, Range("H1")) Is Nothing Then Filter_salekhatameh Range("H1").Value

End Sub

Very Thanks
 
Upvote 0
shafiey said:
I got the drop down multiple select code from another site and it solved the post 63 problem.
Please merge the following two codes for me:

Code 01:

VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
 
If Destination.Count > 1 Then Exit Sub
 
On Error Resume Next
Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError
 
If rngDropdown Is Nothing Then GoTo exitError

If Not Destination.Column = 4 Then GoTo exitError

If Intersect(Destination, rngDropdown) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newValue = Destination.Value
  Application.Undo
  oldValue = Destination.Value
  Destination.Value = newValue
    If oldValue <> "" Then
    If newValue <> "" Then
        If oldValue = newValue Or _
            InStr(1, oldValue, DelimiterType & newValue) Or _
            InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
            Destination.Value = oldValue
                Else
            Destination.Value = oldValue & DelimiterType & newValue
        End If
    End If
    End If
End If
 
exitError:
  Application.EnableEvents = True
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
End Sub

Code 02:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then Filter_namebakhsh Range("D1").Value

  If Not Intersect(Target, Range("F1")) Is Nothing Then Filter_saleshoroo Range("F1").Value

  If Not Intersect(Target, Range("H1")) Is Nothing Then Filter_salekhatameh Range("H1").Value

End Sub

Very Thanks
Click to expand...
The problem was solved.
Thank you
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Extract Comma-Separated Matches Based on Multiple Criteria and Order Preservation
2
Replies
10
Views
740
sobuj53
S
S
  • Solved
"Error In Value" message??
Replies
3
Views
178
Fluff
Fluff
G
  • Solved
Golf Handicap Formula help
2
Replies
11
Views
597
Gulfcourse
G
C
  • Solved
Multi Line Cell - Find Text String
Replies
3
Views
1K
Fluff
Fluff
T
  • Question Question
Range as filter criteria
Replies
5
Views
327
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top