Couper et coller dans une feuille avec Case-Select

Question

Je commence à écrire des macros et j'essaie d'en écrire une pour le travail. Voici un morceau de code avec lequel je me suis battu. Je veux qu'il regarde la feuille «NG304» et trouve les mots clés énumérés dans la colonne B. Si les mots clés sont là, déplacez-les vers la deuxième feuille de calcul «Détail de la paie». Problèmes que j'ai - le code ne passe pas par toute la liste et ne semble pas coller dans la prochaine ligne disponible sur la feuille de calcul détaillée de la paie (il va simplement coller au-dessus de mon en-tête).

code:

Dim Findme As String, Findwhat As String, c As Range 

With ActiveWorkbook.Worksheets("NG304") 

     For Each c In .Range(.Cells(2, "B"), .Cells(Rows.Count, "B").End(xlUp)) 
      Findwhat = vbNullString 
      Findme = StrConv(c.Value2, vbProperCase) 
      Select Case True 
       Case Findme Like "VCIP" 
        Findwhat = "VCIP" 
       Case Findme Like "Company Labor" 
        Findwhat = UCase(Findme) 
       Case Else 
        'do nothing 
      End Select 

     If CBool(Len(Findwhat)) Then 
       With .Parent.Worksheets("NG304") 
        c.EntireRow.Cut Destination:=Worksheets("Payroll Detail").Range("A" & lastrow + 1) 
      lastrow = lastrow + 1 
       End With 
      End If 
     Next c 


    End With 

Answer 1

Cela va filtrer chaque valeur définie dans K_WORDS (en haut), et déplacer les rangées de l'autre feuille:

---

Option Explicit 

Public Sub moveKeywordRows() 
    Const K_WORDS As String = "VCIP,Company Labor"  '<------- Defined keywords 

    Dim wsFrom As Worksheet, wsDest As Worksheet, kw As Variant, i As Long, lr As Long 

    Set wsFrom = ThisWorkbook.Worksheets("NG304") 
    Set wsDest = ThisWorkbook.Worksheets("Payroll Detail") 
    kw = Split(K_WORDS, ",") 

    Application.ScreenUpdating = False 
    For i = 0 To UBound(kw) 
     lr = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row 
     With wsFrom.UsedRange 
      .AutoFilter Field:=2, Criteria1:="=" & kw(i) 
      .Copy 
      wsDest.Cells(lr, "A").PasteSpecial xlPasteAll 
      .SpecialCells(xlCellTypeVisible).EntireRow.Delete 
     End With 
     Application.CutCopyMode = False 
     wsDest.Activate: wsDest.Cells(1, "A").Select 
    Next 

    wsDest.UsedRange.EntireColumn.AutoFit 
    With wsFrom 
     .Activate 'wsFrom.UsedRange.AutoFilter '.ShowAllData 
    End With 
    Application.ScreenUpdating = True 
End Sub 

---

Cette est votre code posté, avec quelques ajustements - il semble fonctionner:

---

Public Sub moveKeywordRows1() 
    Dim FindMe As String, FindWhat As String, c As Range, lr As Long, wsDest As Worksheet 

    Set wsDest = ThisWorkbook.Worksheets("Payroll Detail") 
    With ThisWorkbook.Worksheets("NG304") 
     Application.ScreenUpdating = False 
     For Each c In .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)) 
      FindMe = StrConv(c.Value2, vbProperCase) 
      FindWhat = vbNullString 
      Select Case UCase(FindMe) 
       Case "VCIP":     FindWhat = "VCIP" 
       Case UCase("Company Labor"): FindWhat = "Company Labor" 
      End Select 
      If Len(FindWhat) > 0 Then 
       c.EntireRow.Cut Destination:=wsDest.Range("A" & lr + 1) 
       lr = lr + 1 
      End If 
     Next 
     Application.ScreenUpdating = True 
    End With 
End Sub