12. november 2020 - 14:57Der er
4 kommentarer og 1 løsning
VBA hjælp til gennemløb
Hej Eksperter
Jeg sidder og roder med at sprede en udgift ned på kunder. Jeg har en opgørelse fra leverandør i Excel, den består af flere ark navngivet efter type og så med -månedår bagefter, altså agent-okt20 eller reception-nov20.
Jeg har en makro som startes fra andet ark, den åbner med brugerens hjælp leverandørens projektmappe, og så skal den tage data fra alle sheets i den og sætte sammen i en fane i det ark makroen ligger i. Jeg har styr på det andet, men kan ikke lige se en elegant måde at programmere det gennemløb pr sheet.
For Each ws In Sheets strType = Sheet.Name Sheets(ws).Cells("A2").CurrentRegion.Copy ' her er muligvis mere rubusthed ved at bruge fast kolonne-antal, men hvordan laver jeg linjeantallet fleksibelt? ThisWorkbook.Sheets("Data til Pivot").Range("A1").Paste ' udfordring med at vide hvor den er kommet til? så den ikke overskriver det eksisterende fra tidligere sheets. ' indsæt strType på hver af de kopierede linjer Next
Som I ser er den klare udfordring at styre antal linjer som kan være varierende fra skema til skema. Jeg er derudover meget dårlige til at kopiere i en elegang kode der ikke kræver select og aktivering af sted hvor der skal indsættes.
Se gerne om du kan finde inspiration i denne kode som kopiere alle ark til et nyt oversigtsark. Husk nedenstående laver mellemrum mellem det der indsættes i oversigtsarket fra de forskellige ark. Det er muligvis uhensigtsmæssigt til dit formål.
Sub kopier_ark_til_oversigt()
Dim ws As Worksheet Dim oversigtsark As Worksheet Dim counter As Long Dim ans As Integer
ans = MsgBox("Arket Oversigt bliver slettet!!" & vbNewLine & vbNewLine & "Ønsker du at forsætte?", vbYesNo) Select Case ans Case vbYes GoTo runsub Case vbNo Exit Sub End Select
On Error Resume Next Worksheets("oversigtsark").Delete On Error GoTo 0
Worksheets.Add().Name = "Oversigtsark"
Set oversigtsark = Worksheets("Oversigtsark")
For Each ws In Worksheets If ws.Name <> "Oversigtsark" Then ws.UsedRange.Copy oversigtsark.Cells(oversigtsark.UsedRange.Rows.Count + counter, 1) counter = counter + 2 End If Next ws
With Sheets("Oversigtsark") .Columns.AutoFit .Activate End With
Det jeg fik ud af din hjæp var en rigtig elegant måde at kopiere over: ws.UsedRange.Copy oversigtsark.Cells(oversigtsark.UsedRange.Rows.Count, 1)
Desværre forstår jeg ikke det med counteren, laver den bare yderligere afstand?. Den kopierer (naturligvis) overskrifter med, det kan jeg nok ikke slippe ud af med usedrange, men jeg kan så gennemløbe efterfølgende og slette linjer med samme tekst som A1 i A kolonnen.
Jeg opdager så desværre at used range og for den sags skyld current region tager skjulte linjer med - så jeg ender ud i det jeg gerne ville undgå, men: activesheet.Range("A2:H2", Range("A2:H2").End(xlDown)).copy
Desværre kan jeg ikke få det til at virke i mit loop - jeg har prøvet at sætte ws eller sheets(Ws) i stedet for activesheet, men ingenting virker :-(
For Each ws In ActiveWorkbook.Worksheets ws.Activate strType = Mid(ws.Name, 1, InStr(ws.Name, "-") - 1) ws.Range("I2:I" & Cells(ws.Rows.Count, "A").End(xlUp).Row).Value = strType ws.Range("A2:I2", Range("A2:I2").End(xlDown)).Copy ThisWorkbook.Sheets("Data til Pivot").Cells(ThisWorkbook.Sheets("Data til Pivot").UsedRange.Rows.Count + 2, 1) Next
Jeg nappede det med kopi fra din løsning med usedrange som fungerer godt i det jeg kopierer over til. Det er mig dog en gåde hvorfor det er +2 og ikke +1 til sidst, idet jeg tænker den skal en længere ned end der er usedrange :-)
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
