Kopiering og flytning af data

Beskrivelse

Kopiering og flytning af data

Range objektet bærer to metoder vi skal bruge til at flytte og kopiere data - det er sjovt nok Copy og Cut:

Range("A1").Copy eller Range("A1").Cut

vil henholdsvis kopiere og flytte celle A1 til udklipsholderen. Paste objektet ligger ikke på Range objektet, men til gengæld på Worksheet objektet

Worksheets("Ark2").Paste

vil indsætte indholdet fra udklipsholderen på arkfanen Ark2. Alle 3 metoder tager en Destination parameter, så man med det samme kan angive, hvor man vil placere det man har kopieret eller klippet.

Range("A1").Copy Destination:=Range("B7") Range("A1").Copy Destination:=Worksheets("Ark2").Range("B17")

Vil henholdsvis kopiere celle A1 til henholdsvis B7 og B7 på Ark2. Destinationen parameteren kan også bruges på Paste metoden.

Når man bruger Copy eller Cut metoderne uden Destination parameteren vil den/de celler man har kopieret stå aktive efterfølgende - det kan man fjerne igen med

Application.CutCopyMode = False

Husk at bruge End metoden til at markere de områder, der skal kopieres.

Øvelse

Download dette regneark og skriv følgende makroer:

én, der opretter en arkfane til hver produktgruppe (PC, Printer, Skærm etc.). Er du sej sørger du for at din makro selv finder ud af hvilke produktgrupper, der er repræsenteret i datasættet.
én, der kopierer overskriftlinjen ud på de enkelte arkfaner
én, der kopierer første salgslinje ud på den rigtige produktgruppes arkfane
én, der løber alle linjerne i datasættet igennem og kopierer linjerne ud på den rigtige arkfane
én, der sørger for at oprette en total kolonne med sammentælling i bunden
én, der kan formatere de enkelte arkfaner, så det hele ser godt ud
én, der kan gemme resultatet med et nyt filnavn, der indeholder datoen for den sidste postering i datasættet
én, der kan rydde op igen - dvs. slette de enkelte produktgruppers arkfaner igen

Tilknyt dine makroer til knapper i regnearket og send resultatet til mig.

Løsning

Se mit løsningsforslag her.

Min kode ser sådan her ud:

Sub OpretArkfaner()     FindGrupper     Dim c As Range     For Each c In Range("L2", Range("L2").End(xlDown))         Worksheets.Add(after:=Worksheets("Salg"), Type:=xlWorksheet).Name = c.Value     Next     Worksheets("Salg").Activate End Sub

Sub FjenArkfaner()     Application.DisplayAlerts = False     Dim wks As Worksheet     For Each wks In Worksheets         If wks.Name <> "Salg" Then             wks.Delete         End If     Next     Application.DisplayAlerts = True End Sub

Sub FindGrupper()     Range("F1").EntireColumn.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("L1"), Unique:=True End Sub

Sub KopiOverskrift()     Dim wks As Worksheet     For Each wks In ActiveWorkbook.Worksheets         If wks.Name <> "Salg" Then             Worksheets("Salg").Range("A1", Range("A1").End(xlToRight)).Copy Destination:=Worksheets(wks.Name).Range("A1")         End If     Next End Sub

Sub KopiFørsteLinje()     arknavn = Range("F2").Value     Range("A2", Range("A2").End(xlToRight)).Copy Destination:=Worksheets(arknavn).Range("A2") End Sub

Sub KopiAlle()     Dim c As Range     For Each c In Range("A2", Range("A2").End(xlDown))         arknavn = c.Offset(0, 5).Value         Range(c, c.End(xlToRight)).Copy Destination:=Worksheets(arknavn).Range("A65536").End(xlUp).Offset(1, 0)     Next End Sub

Sub TotalKolonne()     Dim wks As Worksheet     For Each wks In ActiveWorkbook.Worksheets         If wks.Name <> "Salg" Then             wks.Activate             Range("J1").Value = "Total"             Range("J2", Range("I2").End(xlDown).Offset(0, 1)).Formula = "=I2*H2"             Range("J2").End(xlDown).Offset(1, 0).Formula = "=sum(J2:" + Range("J2").End(xlDown).Address + ")"             Range("J1").EntireColumn.Style = "Comma"         End If     Next     Worksheets("Salg").Activate End Sub

Sub Formatering()     Dim wks As Worksheet     For Each wks In ActiveWorkbook.Worksheets         wks.Activate         FormaterOverskrift         FormaterData         Autotilpas     Next     Worksheets("Salg").Activate End Sub

Sub Autotilpas()     Range("A1", Range("A1").End(xlToRight)).EntireColumn.AutoFit End Sub

Sub FormaterOverskrift()     With Range("A1", Range("A1").End(xlToRight))         .Interior.ColorIndex = 3         .Font.Bold = True         With .Borders(xlEdgeBottom)             .LineStyle = xlBorderLineStyleContinuous             .Weight = xlThick             .ColorIndex = 0         End With     End With End Sub

Sub FormaterData()     Dim c As Range     For Each c In Range("A2", Range("A2").End(xlDown))         With Range(c, c.End(xlToRight))             If (c.Row Mod 2) = 0 Then                 .Interior.ColorIndex = 15             Else                 .Interior.ColorIndex = 16             End If         End With     Next End Sub

Sub RydOp()     FjenArkfaner     NulStilFormatering     Range("L1", Range("L1").End(xlDown)).Clear End Sub

Sub NulStilFormatering()     Range("A1", Range("A1").End(xlToRight).End(xlDown)).ClearFormats End Sub

Bemærk, at der i koden gemmer sig eksempler på, hvordan man løber et antal arkfaner igennem.

Et par af makroerne flimrer lidt når de kører - det kan man eliminere ved at skyde linjen

Application.ScreenUpdating = False

Ind i starten af koden - og naturligvis

Application.ScreenUpdating = True

i slutningen.

Forrige Arbejde med dokumenter

Næste Forms

Brug for hjælp til VBA, VSTO eller SQL?

Scient Data tilbyder professionel IT-konsulentbistand

Kontakt Scient Data →