Just nu i M3-nätverket
Jump to content

Filtrera ut unika rader med Excel VBA


Tommy H

Recommended Posts

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

Link to comment
Share on other sites

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...

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

Archived

This topic is now archived and is closed to further replies.



×
×
  • Create New...