06. juni 2007 - 22:14Der er
13 kommentarer og 1 løsning
Makro til at kopiere filtrerede data til andre arkfaner
Jeg har behov for en makro som udfører følgende :
I arkfane 1 findes mine rådata, som i kolonne A har oplysninger om et afdelingsnummer, hvis data i de øvrige kolonner gerne skulle kopieres over i underliggende arkaner, hver især repræsenterende sit eget afdelingsnummer.
Hver afdelings-arkfane er en standardskabelon, bestående af nogle kolonneoverskrifter i række 3, og en summering i række 7. Rådata skal så indsættes i række 4 og nedefter, resulterende i at række 7 rykkes nedad i forhold til antallet af rækker som hentes fra rådata. Eksempel :
KolA KolB KolC 072 100 A 072 200 B 085 100 C 072 200 D 085 100 E
Der er sat autofilter på kolonne A i rådata.
Makroen skal så finde eksempelvis afdeling 072 i KolA, kopiere de 3 rækker i KolB og KolC til en arkfane benævnt 072, indsætte disse i celle A4/B4 og nedefter, og samtidig rykke beregningerne i række 7 ned til række 9
Grunden til at jeg skal flytte beregningerne, og eksempelvis ikke benytte en makro til at genoprette beregningerne et vilkårligt sted i arket er, at der er kæder til andre arkfaner.
Til andre brugere: Makroen skulle også kunne overflytte data fra arket "sorteret" som er behæftede med fejl.
Data med fejl angives med "Fejl i data" i kolonne A.
Sub overførPosterOgFejl()
overførPoster overførFejl End Sub Sub sletPosterOgFejl()
SletPoster SletFejl End Sub
Private Sub overførPoster() Dim a As Variant
Call SletPoster
a = Sheets("Sorteret").Cells(2, 2).CurrentRegion
For Each sht In ActiveWorkbook.Sheets shtName = LCase(Left(sht.Name, 7)) If shtName = "selskab" Then sht.Activate Call overførPost End If
Next
Sheets("Sorteret").Activate
End Sub
Private Sub overførPost() Dim rng As Range Dim Count As Integer Count = 0 Application.ScreenUpdating = False i = 1 a = Sheets("Sorteret").Cells(4, 1).CurrentRegion Nr = CInt(Right(ActiveSheet.Name, 4))
While i <= UBound(a) If IsNumeric(Trim(a(i, 1))) Then If CInt(Trim(a(i, 1))) = Nr Then Count = Count + 1 End If i = i + 1 Wend If Count = 0 Then Exit Sub
Rows("5:" & Count + 3).Insert Shift:=xlDown
i = 1 While i <= UBound(a) If IsNumeric(Trim(a(i, 1))) Then If CInt(Trim(a(i, 1))) = Nr Then Set rng = Range("A65000").End(xlUp).Offset(1) rng.Select rng.Select rng.Offset(, 0) = a(i, 2) rng.Offset(, 1) = a(i, 3) rng.Offset(, 2) = a(i, 4) rng.Offset(, 3) = a(i, 5) rng.Offset(, 4) = a(i, 6) rng.Offset(, 5) = a(i, 7) rng.Offset(, 6) = a(i, 8) rng.Offset(, 7) = a(i, 9) End If End If i = i + 1 Wend rLast = Range("A65000").End(xlUp).Row Range("H" & rLast + 1).Formula = "=SUM(H4:H" & rLast & ")" End Sub
Private Sub SletPoster()
For Each sht In ActiveWorkbook.Sheets shtName = LCase(Left(sht.Name, 7)) If shtName = "selskab" Then sht.Activate rLast = Range("A65000").End(xlUp).Row If Range("A4") <> "" Then Range(Cells(4, 1), Cells(rLast, 1)).EntireRow.Value = "" Range(Cells(5, 1), Cells(rLast, 1)).EntireRow.Delete End If
End If
Next Sheets("Sorteret").Activate End Sub
Private Sub overførFejl() Dim rng As Range Dim Count As Integer
SletFejl
Count = 0 Application.ScreenUpdating = False i = 1 a = Sheets("Sorteret").Cells(4, 1).CurrentRegion
While i <= UBound(a) If LCase(a(i, 1)) = LCase("fejl i data") Then Count = Count + 1 i = i + 1 Wend If Count = 0 Then Exit Sub Sheets("Samlet").Activate
Rows("22:" & Count + 20).Insert Shift:=xlDown
i = 1 While i <= UBound(a) If LCase(a(i, 1)) = LCase("fejl i data") Then Set rng = Range("A65000").End(xlUp).Offset(1) rng.Select rng.Offset(, 0) = a(i, 2) rng.Offset(, 1) = a(i, 3) rng.Offset(, 2) = a(i, 4) rng.Offset(, 3) = a(i, 5) rng.Offset(, 4) = a(i, 6) rng.Offset(, 5) = a(i, 7) rng.Offset(, 6) = a(i, 8) rng.Offset(, 7) = a(i, 9) End If i = i + 1 Wend rLast = Range("A65000").End(xlUp).Row Range("H" & rLast + 1).Formula = "=SUM(H21:H" & rLast & ")" End Sub
Private Sub SletFejl()
Sheets("Samlet").Activate rLast = Range("A65000").End(xlUp).Row If Range("A21") <> "" Then Range(Cells(21, 1), Cells(rLast, 1)).EntireRow.Value = "" Range(Cells(22, 1), Cells(rLast, 1)).EntireRow.Delete End If
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.
