Excel VBA ganze Zeile auf neues Blatt basierend auf Zelle Daten kopieren

Question

Ich bin sehr neu zu Excel VBA und brauche etwas Hilfe. Ich habe eine Liste von Daten, die ich auf Basis der Daten in Spalte B in ein neues Blatt kopieren möchte, und kopiere die gesamte Zeile auf ein neues Blatt mit demselben Namen.

Column B 
2nd Black 
1st Black 
1st Brown 
2nd Brown 
3rd Brown 

Ich habe meinen Code geändert und kam mit diesem. Alles funktioniert. Danke für Ihre Hilfe.

Sub create_role() 
Dim c As Range 
Dim j As Integer 
Dim k As Integer 
Dim l As Integer 
Dim m As Integer 
Dim Source As Worksheet 
Dim Target As Worksheet 

Set Source = ActiveWorkbook.Worksheets("master") 

j = 11 
k = 11 
l = 11 
m = 11 

For Each c In Source.Range("b11:b110") 
    If (c = "5th Black" Or c = "4th Black" Or c = "3rd Black" Or c = "2nd Black" Or c = "1st Black" Or c = "Jr. Black") Then 
     Set Target = ActiveWorkbook.Worksheets("BLACK") 
     Source.Rows(c.Row).Copy Target.Rows(j) 
    ElseIf c = "1st Brown" Then 
     Set Target = ActiveWorkbook.Worksheets("1ST BROWN") 
     Source.Rows(c.Row).Copy Target.Rows(k) 
     k = k + 1 
    ElseIf c = "2nd Brown" Then 
     Set Target = ActiveWorkbook.Worksheets("2ND BROWN") 
     Source.Rows(c.Row).Copy Target.Rows(l) 
     l = l + 1 
    ElseIf c = "3rd Brown" Then 
     Set Target = ActiveWorkbook.Worksheets("3RD BROWN") 
     Source.Rows(c.Row).Copy Target.Rows(m) 
     m = m + 1 
    End If 

    j = j + 1 

Next c 

End Sub

Answer 1

Verweise auf einem Arbeitsblatt von seinem Arbeitsblatt .Name property ist Groß- und Kleinschreibung und Sie Vorteil, dass zu nehmen.

Option Explicit 

Sub create_role() 
    Dim src As String, trgtws As String, c As Range 

    With ActiveWorkbook.Worksheets("master") 

     For Each c In .Range(.Cells(11, "B"), .Cells(Rows.Count, "B").End(xlUp)) 
      trgtws = vbNullString 
      src = StrConv(c.Value2, vbProperCase) 
      Select Case True 
       Case src Like "*Black" 
        trgtws = "BLACK" 
       Case src Like "*Brown" 
        trgtws = UCase(src) 
       Case Else 
        'do nothing 
      End Select 

      If CBool(Len(trgtws)) Then 
       With .Parent.Worksheets(trgtws) 
        c.EntireRow.Copy _ 
         Destination:=.Cells(.Cells(Rows.Count, "B").End(xlUp).Row, "A") 
       End With 
      End If 
     Next c 

    End With 
End Sub 

Ich habe Ihre Kriterien Methode zu einem Select Case statement geändert, die hier verwendet werden, um weitere Expansion Bedingungen leichter, aber Ihre IF ... ElseIf ... End If könnte machen sollte.

Der Zielspeicherort geht davon aus, dass in B10 jedes Arbeitsblatts eine Art Spaltenüberschriftsetikett vorhanden ist, wenn darunter keine Werte liegen.