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.
I dette særtema ser vi på, hvordan cloud og AI bliver fundamentet for virksomhedernes digitale forretning, og hvordan de nye muligheder for automatisering og forretningsværdi kan udnyttes uden at miste overblik, sikkerhed og menneskelig kontrol.
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.
