VBA code is not working on every sheet

Zeenation

New Member
Joined
Nov 30, 2020
Messages
6
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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
 

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

Zeenation

New Member
Joined
Nov 30, 2020
Messages
6
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Aug 31, 2016
Messages
3,957
.
See if this works ... paste in the ThisWorkbook module :

VBA Code:
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

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
Hi @Zeenation, welcome to the Mr Excel board.

Try this, goes in the ThisWorkbook module...

VBA Code:
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

VBA Code:
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

New Member
Joined
Nov 30, 2020
Messages
6
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

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

VBA Code:
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

New Member
Joined
Nov 30, 2020
Messages
6
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
.
See if this works ... paste in the ThisWorkbook module :

VBA Code:
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

Well-known Member
Joined
Aug 31, 2016
Messages
3,957
Post your workbook to a cloud site for download. No confidential data please.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,321
Messages
5,624,012
Members
416,005
Latest member
judi slot terbaik

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
Top