Just nu i M3-nätverket
Gå till innehåll

Filtrera ut unika rader med Excel VBA


Tommy H

Rekommendera Poster

Hej!

Jag skulle behöva sortera ut dom rader i en databas där det i kolumn "G" är ifyllt ett värde större än "0" t.ex.

 

Jag har knåpat en del på följande men det tar "allting" fram till sista ifyllda värdet. Det förekommer ju ett antal rader där "G-kolumnen" är tom och dessa ska ju då hoppas över.

Urvalet vill jag sedan stoppa in på ett annat blad.

/

Sub Urval()
     Dim rad As Integer
     Dim ws As Worksheet
    
    
     Set ws = Worksheets("KALLE") 'här skulle jag vilja ha det aktiva bladet eftersom det kan vara olika blad vid varje tillfälle
     rad = ws.Range("G6:G50").Find(What:="*", LookIn:=xlValues, After:=ws.Range("G50"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
     ws.Range("B1:H" & rad).Copy
     ws.Range("L1").PasteSpecial Paste:=xlPasteValues 'och här ska det unika urvalet kopieras till ett annat blad
     Application.CutCopyMode = False
 End Sub

/

Detta plockar även med t.ex raderna 8-10 även om dom inte är ifyllda om rad 11 är ifylld.

 

Någon med en bra lösning?

 

//TH

Länk till kommentar
Dela på andra webbplatser

Kanske

Sub Urval()
    Dim myRn As Range
    Dim ar As Range
    Dim rnTarget As Range
    Set rnTarget = Blad2.Range("l1")
    With Blad1 'activesheet
        Set myRn = .Range("G1:G9").SpecialCells(xlCellTypeConstants)
        For Each ar In myRn.Areas
            ar.Offset(, -5).Resize(, 7).Copy
            rnTarget.PasteSpecial Paste:=xlPasteValues
            Set rnTarget = rnTarget.Offset(ar.Rows.Count)
        Next ar
    End With
    Application.CutCopyMode = False
End Sub

fast jag tror jag läst din fråga fel men det tar jag imorgon...

Länk till kommentar
Dela på andra webbplatser

Nu läser jag igen. Alla rader med värde större än noll inom ett givet område.

Sub Urval()
    Dim myRn As Range
    Dim ar As Range
    Dim myCell As Range
    Dim rnTarget As Range
    Set rnTarget = Blad2.Range("l1") 'måcell och blad
    With Blad1.Range("G1:G9") 'ändra blad1 till rätt referens, din källa
        For Each myCell In .Cells
            If myCell <> 0 Then 'villkor för att rad ska kopieras
                If myRn Is Nothing Then
                    Set myRn = myCell.Offset(, -5).Resize(, 7)  'skapar korrekt referens
                Else
                    Set myRn = Union(myRn, myCell.Offset(, -5).Resize(, 7))
                End If
            End If
        Next myCell
        myRn.Copy 'kopierar
        rnTarget.PasteSpecial Paste:=xlPasteValues 'klistrar in allt i ett svep
        
    End With
    Application.CutCopyMode = False
End Sub

Se kommentarer i texten, fråga om det är något.

Länk till kommentar
Dela på andra webbplatser

Arkiverat

Det här ämnet är nu arkiverat och är stängt för ytterligare svar.

×
×
  • Skapa nytt...