22. april 2014 - 10:58Der er
10 kommentarer og 1 løsning
VBA: kopier række til nyt ark
Jeg mangler en vba kode til at kopiere data fra et ark til et andet.
Jeg har en liste med 4 kolonner som skal kopieres. Det skal foregå på den måde, at hver rækkes 4 celler skal kopieres til det andet ark men ved siden af hinanden.
1) Ark1: a1, b1, c1 og d1 kopieres til ark2: a1, b1, c1 og d1. 2) Ark1: a2, b2, c2 og d2 kopieres til ark2: e1, f1, g1 og h1.
Dette gentages, men kun indtil (og her kommer det svære) data i ark1 kolonne D ændrer sig. Herefter startes på ny linje på ark2.
Her er et udspil du kan afprøve. Anbringes under ark1. Kan igangsættes via Alt+F8 / Afspil makro
Rem Ark1 Dim antalRæk As Integer Dim ræk As Integer, kolD As Variant
Rem Ark2 Dim ræk2 As Integer, kol2 As Integer Public Sub samlingPåArk2() antalRæk = ActiveCell.SpecialCells(xlLastCell).Row ræk2 = 1 kolD = Range("D1")
For ræk = 1 To antalRæk If ræk = 1 Then kolD = Range("D1") kol2 = 1 Else If Range("D" & ræk) = kolD Then kol2 = kol2 + 4 Else kol2 = 1 ræk2 = ræk2 + 1 End If End If flytTilArk2 Next ræk End Sub Private Sub flytTilArk2() With ActiveWorkbook.Sheets(1) .Range("A" & ræk & ":D" & ræk).Select Selection.Copy
Jeg har lagt hele koden under ark1. Når jeg kører den via makroer, så sker der ikke noget. Hvis jeg til gengæld går ind i koden og holder f8 nede så begynder den at køre koden igennem og kopiere cellerne.
Det virker næsten som det skal. Når koden når til at data i kolonne 4 ændrer sig, begynder den at kopiere nedaf istedet.
Rem Version 2 Rem Ark1 Dim antalRæk As Integer Dim ræk As Integer, kolD As Variant
Rem Ark2 Dim ræk2 As Integer, kol2 As Integer Public Sub samlingPåArk2() antalRæk = ActiveCell.SpecialCells(xlLastCell).Row ræk2 = 1 kolD = Range("D1")
For ræk = 1 To antalRæk If ræk = 1 Then kolD = Range("D1") kol2 = 1 Else If Range("D" & ræk) = kolD Then kol2 = kol2 + 4 Else kol2 = 1 ræk2 = ræk2 + 1 kolD = Range("D" & ræk) 'tilføjelse i version 2 End If End If flytTilArk2 Next ræk End Sub Private Sub flytTilArk2() With ActiveWorkbook.Sheets(1) .Range("A" & ræk & ":D" & ræk).Select Selection.Copy
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.