Makro med If og Do... 2

Det kan gøres på manger måder - her er en:

Public Sub Demo()
    Dim rCell As Range
    Dim wks2 As Worksheet
    Dim wks3 As Worksheet
   
    Set wks2 = Worksheets("Ark2")
    Set wks3 = Worksheets("Ark3")

    For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
        rCell.EntireRow.Copy
        Select Case UCase(rCell.Offset(0, 6).Value)
            Case "PRO"
                wks2.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Case "STANDARD"
                wks3.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End Select
    Next rCell

    ' Clean up
    Application.CutCopyMode = False
    Set wks2 = Nothing
    Set wks3 = Nothing
End Sub

Det nærmer sig, og unskyld hvis jeg stiller for mange krav, men i dette tilfælde vil der jo komme tomme rækker på ark2 og ark3. Kan dette undgåes?

Davis

har du prøvet ?

JA, og jeg har nu efterfølgende lavet lidt om så arkene automatisk sorterer... Meget simpelt. Men hvordan får jeg slettet arkene og får den til at vende tilbage til det aktive ark... De steder med XXX ved jeg godt at der er fejl...

Public Sub sorter()
    Dim rCell As Range
    Dim wks2 As Worksheet
    Dim wks3 As Worksheet
XXX  Dim asheet As String
     
    Set wks2 = Worksheets("2003")
    Set wks3 = Worksheets("2004")
 
    Sheets("2003").Select
    Cells.Select
    Selection.ClearContents
    Sheets("2004").Select
    Cells.Select
    Selection.ClearContents
    Sheets("2005").Select
    Cells.Select
    Selection.ClearContents
  XXX  Sheets(asheet).Select (Her vil jeg gerne have at den går tilbage til det aktive ark, der skal deles ud på de andre...

    For Each rCell In activesheet.UsedRange.Columns(1).Cells
        rCell.EntireRow.Copy
        Select Case UCase(rCell.Offset(0, 17).Value)
            Case "2003"
                wks2.Range("A65536").End(xlUp).Offset(3, 0).PasteSpecial xlPasteValues
            Case "2004"
                wks3.Range("A65536").End(xlUp).Offset(3, 0).PasteSpecial xlPasteValues
        End Select
    Next rCell

    ' Clean up
    Application.CutCopyMode = False
    Set wks2 = Nothing
    Set wks3 = Nothing
    Sheets("2003").Select
    ActiveWindow.ScrollRow = 1
    Range("A4:R432").Select
    Selection.Sort Key1:=Range("R4"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets("2004").Select
    ActiveWindow.ScrollRow = 1
    Range("A4:R432").Select
    Selection.Sort Key1:=Range("R4"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets("2005").Select
    ActiveWindow.ScrollRow = 1
    Range("A4:R432").Select
    Selection.Sort Key1:=Range("R4"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom





End Sub

En detalje - Select metoden er en langsom fætter, og bruge helst aldrig
Mon ikke du er ude i noget der ligner dette her - prøv engang:

Public Sub sorter()
    Dim rCell As Range
    Dim wks2003 As Worksheet
    Dim wks2004 As Worksheet
    Dim wks2005 As Worksheet
     
    Set wks2003 = Worksheets("2003")
    Set wks2004 = Worksheets("2004")
    Set wks2005 = Worksheets("2005")
   
    ' Clean sheets
    wks2003.UsedRange.ClearContents
    wks2004.UsedRange.ClearContents
    wks2005.UsedRange.ClearContents

    ' Paste data to sheets
    For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
        rCell.EntireRow.Copy
        Select Case UCase(rCell.Offset(0, 17).Value)
            Case "2003"
                wks2003.Range("A65536").End(xlUp).Offset(3, 0).PasteSpecial xlPasteValues
            Case "2004"
                wks2004.Range("A65536").End(xlUp).Offset(3, 0).PasteSpecial xlPasteValues
            Case "2005"
                wks2005.Range("A65536").End(xlUp).Offset(3, 0).PasteSpecial xlPasteValues
        End Select
    Next rCell

    ' Sortering
    wks2003.Range("A4:R432").Sort Key1:=Range("R4"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    wks2004.Range("A4:R432").Sort Key1:=Range("R4"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    wks2005.Range("A4:R432").Sort Key1:=Range("R4"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    ' Clean up
    Application.CutCopyMode = False
    Set wks2003 = Nothing
    Set wks2004 = Nothing
    Set wks2005 = Nothing
End Sub