VBA code is not working on every sheet

[Zeenation]

On module
Sub FIllRankProject(Niederlassung As String, Amount As Integer, ws As Worksheet)
Worksheets("ValuesG").Select
ActiveWorkbook.Worksheets("ValuesG").ListObjects("PQ_ProjektContr_G") _
.Sort.SortFields.Clear
'ActiveSheet.ShowAllData
ActiveSheet.ListObjects("PQ_ProjektContr_G").Range.AutoFilter Field:=3, _
Criteria1:=Niederlassung

ActiveWorkbook.Worksheets("ValuesG").ListObjects("PQ_ProjektContr_G") _
.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ValuesG").ListObjects("PQ_ProjektContr_G") _
.Sort.SortFields.Add Key:=Range("PQ_ProjektContr_G[[#All],[FY2020]]"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ValuesG").ListObjects( _
"PQ_ProjektContr_G").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With






Dim rng As Range
Set rng = Worksheets("ValuesG").Range("PQ_ProjektContr_G[FY2020]")
Dim ProjectCounter As Integer

For Each cl In rng
If cl.EntireRow.Hidden = False Then
ws.Cells(122 + ProjectCounter, 2) = cl.Row
ProjectCounter = ProjectCounter + 1
If ProjectCounter = Amount Then Exit For
End If
Next

ws.Select

End Sub

on sheet
Private Sub Worksheet_Change(ByVal Target As Range) 'Excel VBA with more cells in the range.
If Not Intersect(Target, Range("E4")) Is Nothing Then
Dim lastCell As Range
Set lastCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
ActiveSheet.Range("B" & 122 & ":B200").Value = ""
Call FIllRankProject(Target.Value, lastCell.Value, ActiveSheet)
End If
End Sub

 

[Zeenation]

I want to copy row number from a sheet based on a criteria, for this i wrote code on module and on sheet separately. but this doesnt work for more then one sheet. can someone help

 

[Logit]

.
See if this works ... paste in the ThisWorkbook module :

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Intersect(Target, Range("E4")) Is Nothing Then
        Dim lastCell As Range
        Set lastCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
        ActiveSheet.Range("B" & 122 & ":B200").Value = ""
        Call FIllRankProject(Target.Value, lastCell.Value, ActiveSheet)
    End If

End Sub

 

[GWteB]

Hi @Zeenation, welcome to the Mr Excel board.

Try this, goes in the ThisWorkbook module...

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Intersect(Target, Sh.Range("E4")) Is Nothing Then
        Dim lastCell As Range
        Set lastCell = Sh.Cells(Rows.Count, "A").End(xlUp)
        Sh.Range("B122:B200").Value = ""
        Call FIllRankProject(Target.Value, lastCell.Value, Sh)
    End If
End Sub

... and this in a standard module

Sub FIllRankProject(Niederlassung As String, Amount As Integer, ws As Worksheet)

    Worksheets("ValuesG").Select
    
    With Worksheets("ValuesG").ListObjects("PQ_ProjektContr_G")
    
        .Sort.SortFields.Clear
'ActiveSheet.ShowAllData
        .Range.AutoFilter Field:=3, Criteria1:=Niederlassung
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("PQ_ProjektContr_G[[#All],[FY2020]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

    Dim rng As Range, cl As Range
    Dim ProjectCounter As Integer

    Set rng = Worksheets("ValuesG").Range("PQ_ProjektContr_G[FY2020]")

    For Each cl In rng
        If cl.EntireRow.Hidden = False Then
            ws.Cells(122 + ProjectCounter, 2) = cl.Row
            ProjectCounter = ProjectCounter + 1
            If ProjectCounter = Amount Then Exit For
        End If
    Next

    ws.Select
End Sub

 

[Zeenation]

.
See if this works ... paste in the ThisWorkbook module :

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Intersect(Target, Range("E4")) Is Nothing Then
        Dim lastCell As Range
        Set lastCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
        ActiveSheet.Range("B" & 122 & ":B200").Value = ""
        Call FIllRankProject(Target.Value, lastCell.Value, ActiveSheet)
    End If

End Sub

This code is also not working, there is no error, but it doesnt show row number in return. i have 10 sheets. each sheet should carry relavent row number from value sheet based upon the criteria. i wrote one code in module and one in individual sheet. it worked before but now i have changed the pc and it doesnt work.

 

[Zeenation]

.
See if this works ... paste in the ThisWorkbook module :

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Intersect(Target, Range("E4")) Is Nothing Then
        Dim lastCell As Range
        Set lastCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
        ActiveSheet.Range("B" & 122 & ":B200").Value = ""
        Call FIllRankProject(Target.Value, lastCell.Value, ActiveSheet)
    End If

End Sub

It works only for one sheet, but when i try to run it on other sheets it just not work

 

[Logit]

Post your workbook to a cloud site for download. No confidential data please.