06. juni 2007 - 22:14
Der 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.
Nogen ideer til denne opgave ?
16. juni 2007 - 07:03
#12
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
Sheets("Sorteret").Activate
End Sub
