Excel VBA - Kopiere data fra flere ark

LEIK

22. desember 2019

Hei godtfolk!

Begynte på et skript som jeg trodde skulle være veldig enkelt, men jeg har prøvd mye forskjellig og får det ikke til å virke.
Jeg har mange regneark med data. Jeg ønsker å loope med gjennom alle disse arkene. Dersom celle i kolonne E eller F ikke er tom, skal hele raden kopieres til et ark kalt "Kombinert". Er det noen som ser hvorfor dette ikke virker?

Hadde dette fungert skulle ca. 20 rader vært kopiert til "Kombinert", men ingenting kopieres

Kode

Sub kombinerArk()

    Dim wrk As Workbook
    Dim sht As Worksheet
    Dim rng As Range, cell As Range

    
     
    Set wrk = ActiveWorkbook
     
    Application.ScreenUpdating = False
    
    Sheets("Kombinert").Move after:=Worksheets(Worksheets.Count) 'Gjør at "Kombinert" blir det siste arket
    
    lastRowKombinert = Sheets("Kombinert").Range("A" & Rows.Count).End(xlUp).Row + 1
         
    'Starter loop
    For Each sht In wrk.Worksheets
        
        If sht.Index = wrk.Worksheets.Count Then 'Gjør at løkke stoppes når man kommer til det siste arket (Kombinert)
            Exit For
        End If
   
        Set rng = ActiveSheet.Range("E3:F100")
        For Each cell In rng
        If cell.Value <> "" Then 'Sjekker om celler i kolonne E eller F IKKE er tomme
            ActiveCell.EntireRow.Copy Sheets("Kombinert").Range("A" & lastRowKombinert)
        End If
        Next cell
    Next sht
    
    Application.ScreenUpdating = True
End Sub

Sånn ser regnearkene ut, og for dette arket skulle 6 linjer vært kopiert til "kombinert".

NAPse

I see you...

380 221

24. desember 2019

Hovedproblemet ser ut til å være at du ikke aktiverer de gjeldene arbeidsarkene og cellene. (Se linje 18 og 29)
Øvrig så inkrementeres lastRowKombinert med en dersom noe blir lagt inn i kombinert arket.
Ellers har jeg ikke gjort noen andre endringer.

God jul!

Det gikk litt fort i svingene der. Jeg ser nå at flere av radene dukker opp dobbelt i kombinert arket. Det er nok fordi scriptet sjekker både for kolonne E og F hver for seg.

Har nå endret range (linje 25) til å kun ta for seg kolonne E, og sjekker dermed E og F i samme slengen. Da ungår du duplikater dersom det er fyllt inn noe i begge kolonnene.

Kode

Sub kombinerArk()
 
    Dim wrk As Workbook
    Dim sht As Worksheet
    Dim rng As Range, cell As Range
 
    Set wrk = ActiveWorkbook
     
    Application.ScreenUpdating = False
    
    Sheets("Kombinert").Move after:=Worksheets(Worksheets.Count) 'Gjør at "Kombinert" blir det siste arket
    
    lastRowKombinert = Sheets("Kombinert").Range("A" & Rows.Count).End(xlUp).Row + 1
         
    'Starter loop
    For Each sht In wrk.Worksheets
        'Aktiver gjeldene ark
        sht.Activate
        
        If sht.Index = wrk.Worksheets.Count Then 'Gjør at løkke stoppes når man kommer til det siste arket (Kombinert)
            Exit For
        End If
        
   
        Set rng = ActiveSheet.Range("E3:E100")
        For Each cell In rng
            'Aktiver gjeldene celle
            cell.Activate
            If cell.Value <> "" Or cell.Next <> "" Then 'Sjekker om celler i kolonne E eller F IKKE er tomme
                ActiveCell.EntireRow.Copy Sheets("Kombinert").Range("A" & lastRowKombinert)
                
                'Øk siste rad med 1
                lastRowKombinert = lastRowKombinert + 1
            End If
            Next cell
        Next sht
    
    Application.ScreenUpdating = True
End Sub

Sist endret av NAPse; 24. desember 2019 kl. 15:49. Grunn: Automatisk sammenslåing med etterfølgende innlegg.

Pope

LEIK

Trådstarter

2.529 903

24. desember 2019

Ahhh, det tenkte jeg faktisk på, men regnet med at arkene automatisk ble aktivert i loopen. Tusen takk

Men hva skjer dersom det bare er det kun finnes endringer i kolonne F?

Dersom det fylles ut noe, bør det fylles i både kolonne E og F. Jeg får nok til å legge inn en If-statement som gir en advarsel om dette, ved å bruke offset for å sjekke nabocellen

Veldig forbøyd med hjelpen!

Sist endret av Pope; 24. desember 2019 kl. 19:06. Grunn: Automatisk sammenslåing med etterfølgende innlegg.

NAPse

I see you...

380 221

26. desember 2019

Sitat av Pope

Men hva skjer dersom det bare er det kun finnes endringer i kolonne F?

Vis hele sitatet...

Slik skriptet er nå vil raden legges inn i kombinert arket dersom det finnes verdier i E eller F kolonnen, eller begge.
cell.Next vil tilsvare cellen til høyre for den gjeldene cellen i E kolonnen, altså F kolonnen.

Nå vet jeg ikke hvordan du tenker å trigge skripet, men er det slik at det skal trigges på endringer i cellene?

Sitat av Pope

Dersom det fylles ut noe, bør det fylles i både kolonne E og F. Jeg får nok til å legge inn en If-statement som gir en advarsel om dette, ved å bruke offset for å sjekke nabocellen

Veldig forbøyd med hjelpen!

Vis hele sitatet...

Dersom du ønsker at kun rader hvor både E og F er utfyllt trenger du bare endre Or til And i If-statementen som sjekker at cellene ikke er tomme.

Kan også legge til at dersom skriptet kjøres flere ganger vil neste kjøring legge inn alle radene på nytt under radene fra forrige kjøring. Dersom det ikke er ønskelig må radene i kombinert arket slettes før kjøring.

F.eks:

SPOILER ALERT! Vis spoiler

Kode

    Sub kombinerArk()
     
        Dim wrk As Workbook
        Dim sht As Worksheet
        Dim rng, rmv As Range, cell As Range
     
        Set wrk = ActiveWorkbook
         
        Application.ScreenUpdating = False
        
        Sheets("Kombinert").Move after:=Worksheets(Worksheets.Count) 'Gjør at "Kombinert" blir det siste arket
        
        Set rmv = ActiveSheet.Range("A2:F100")
        Sheets("Kombinert").Activate
        rmv.Clear
        
        lastRowKombinert = Sheets("Kombinert").Range("A" & Rows.Count).End(xlUp).Row + 1
             
        'Starter loop
        For Each sht In wrk.Worksheets
            'Aktiver gjeldene ark
            sht.Activate
            
            If sht.Index = wrk.Worksheets.Count Then 'Gjør at løkke stoppes når man kommer til det siste arket (Kombinert)
                Exit For
            End If
            
       
            Set rng = ActiveSheet.Range("E3:E100")
            For Each cell In rng
                'Aktiver gjeldene celle
                cell.Activate
                If cell.Value <> "" Or cell.Next <> "" Then 'Sjekker om celler i kolonne E eller F IKKE er tomme
                    ActiveCell.EntireRow.Copy Sheets("Kombinert").Range("A" & lastRowKombinert)
                    
                    'Øk siste rad med 1
                    lastRowKombinert = lastRowKombinert + 1
                End If
                Next cell
            Next sht
        
        Application.ScreenUpdating = True
    End Sub

Sist endret av NAPse; 26. desember 2019 kl. 14:39.