Ein Fehler auftritt/einfrieren mit COUNTIF in VBA

Question

Ich versuche, eine Liste von Namen auf einem Blatt zu nehmen, zu überprüfen, ob es auf einem zweiten Blatt erscheint, und wenn ja, auf einem dritten Blatt den Namen und anzeigen wie oft es angezeigt wird.

Ich habe irgendwo Code gefunden und versucht, ihn für meine Zwecke anzupassen. Ich habe Do Bis IsEmpty verwendet, um durch das erste Arbeitsblatt und zwei verschachtelte IF-Anweisungen zu überprüfen, ob der Name auf dem zweiten Blatt angezeigt wird, und COUNTIF, um sie zu berechnen.

Ich dachte, ich hätte alles richtig gemacht, aber wenn ich das Makro versuche, läuft es für einen Moment, dann legt er auf und friert ein. Ich bin sehr neu bei VBA und habe wahrscheinlich ein paar sehr einfache Fehler gemacht, aber ich bin nicht vertraut genug mit VBA, um den Fehler zu finden.

Unten ist der Code, den ich verwende.

Sub NS_FPS_Macro() 
Dim NSName As String 
Dim FPSCount As String 

Application.ScreenUpdating = False 

NSName = Worksheets("Summary_Report").Range("B2").Select 

Do Until IsEmpty(Worksheets("Summary_Report").Range("B:B")) 
    Sheets("FPS_Report").Activate 
    If ActiveCell.Value = NSName Then 
     Found = True 
    End If 

    If Found = True Then 
     FPSCount = Application.WorksheetFunction.CountIf(Range(Worksheets("FPS_Report").Range("B:B")), NSName) 
     Destination = Sheets("Report").Cells(Rows.Count, "A").End(xlUp).Offset(1) 
    End If 
ActiveCell.Offset(1, 0).Select 
Loop 

Application.ScreenUpdating = True 

End Sub 

Answer 1

Der Grund für die Endlos-Schleife ist, dass Worksheets("Summary_Report").Range("B:B") wird nie leer sein.

Do Until IsEmpty(Worksheets("Summary_Report").Range("B:B"))

Man könnte es so beheben:

Do Until IsEmpty(ActiveCell.Offset(1, 0))

Aber Sie sollten vermeiden, wann immer möglich, die Auswahl oder aktivieren.

Sub NS_FPS_Macro() 
    Dim c As Range, CountRange As Range, NamesRange As Range, DestRange As Range 
    Dim FPSCount As Long 

    With Worksheets("FPS_Report") 
     Set CountRange = Intersect(.UsedRange, .Range("B:B")) 
    End With 

    With Worksheets("Summary_Report") 
     Set NamesRange = .Range("B2", .Range("B" & Rows.Count).End(xlUp)) 
    End With 

    For Each c In NamesRange 

     FPSCount = Application.WorksheetFunction.CountIf(CountRange, c.Text) 
     If FPSCount > 0 Then 

      Set DestRange = Sheets("Report").Cells(Rows.Count, "A").End(xlUp).Offset(1) 
      DestRange.Value = c.Value 
      DestRange.Offset(0, 1).Value = FPSCount 

     End If 
    Next 

End Sub 

Answer 2

Dies könnte Ihnen helfen. Es müsste höchstwahrscheinlich modifiziert werden, um zu Ihren Daten zu passen. Es legt einen Namensbereich und einen Suchbereich fest und sucht dann nach den einzelnen Namen. Wenn es gefunden wird, behält es es für sich und speichert es schließlich auf einem separaten Blatt.

Sub NameSearch() 

Dim nameSource As range 
Dim searchRange As range 
Dim name As range 
Dim counter As Integer 
Dim openRow As Integer 

'Keep track of how many times a name is found. 
counter = 0 

'The row where you want to store the data, mine is a blank sheet so I am starting 
'at the first row. 
openRow = 1 

'Get the range that has the names to look for. Modify for your data. 
Set nameSource = Sheets("Summary_Report").range("A1", "A4") 

'Get the range to search for the name. Modify for your data. 
Set searchRange = Sheets("FPS_Report").range("A1", "A15") 

'Look through the search range. If a name is found, add one to the counter, and continue 
For Each name In nameSource 
    Set c = searchRange.Find(name.Value) 
    If Not c Is Nothing Then 
     firstAddress = c.address 
     Do 
      counter = counter + 1 
      Set c = searchRange.FindNext(c) 
     Loop While Not c Is Nothing And c.address <> firstAddress 
    End If 

    'If counter isn't 0, then name was found at least once 
    If counter <> 0 Then 
     Sheets("Report").range("A" & openRow).Value = name.Value 
     Sheets("Report").range("B" & openRow).Value = counter 

     'increment next row and reset counter 
     openRow = openRow + 1 
     counter = 0 
    End If 

Next name 


End Sub