Overfør data med VBA fra flere ark til et enkelt ark
Jeg er ved at lave en makro der samler data fra flere ark i ét enkelt ark. Kildedata ligger i et ark for hver uge. Koden skal kunne overføre data for ugerne i en hel måned og indsæt dem samlet i et enkelt ark.Data bliver overført ud fra flere kriterier, såsom tidspunkt, ID-nr. og betalingskort.
Det er forskelligt fra uge til uge hvor mange rækker der er fra kildedata.
Kolonneoverskrifterne skal overføres til destinationsarket sammen med kildedata, kun fra 1. uge i måneden.
En mulighed er også, at kolonneoverskrifter ikke bliver overført sammen med data. Jeg kan lave dem statisk i destinationsarket, da de ikke ændre sig.
Den kode jeg arbejder med, har jeg fundet her på sitet og har forsøgt at tilpasset den.
http://www.eksperten.dk/spm/955698
Men nu er jeg stødt på nogle problemer, som jeg skal have hjælp til.
Case:
Destinationsark: Samling af data for en hel måned.
Kildeark: Indeholder hver især data for en hel uge, og er navngivet med ugenummer til sidst i navnet, fx StamExcel.49
Der skal altså overføres data fra 4-6 kildeark hver måned, alt efter hvordan ugerne er fordelt på en hel måned.
Problem 1.
Afgrænsning af data i starten og slutningen af måneden med kriterier for dato og klokkeslæt.
Fx fra 1. december kl. 00:00 til 31. december kl. 23:59.
Jeg ved ikke hvordan man laver en kode, der sorterer, så alle data med datoer der er større end fx 1. december kl. 00:00, bliver overført til destinationsarket.
De andre kriterier skal stadig være opfyldt (ID nr. og betalingskort).
Tilsvarende skal der sorteres i slutningen af måneden (mindre end 31. december kl. 23:59)
Problem 2.
Indsæt data i destinationsarket forløbende, dvs. data fra 1. uge bliver indsat fx frem til række 20 (her med start i række 2).
Derefter skal data fra 2. uge indsættes fra række 21 og videre ned. Det samme med de efterfølgende ark 2 - 4 ark.
Det sidste ark skal så sorteres, så der ikke kommer data med fra næste måned. (mindre end 31. december kl. 23:59).
Koden:
Option Explicit
Option Base 1
Public Sub FlytData()
Dim RåData1 As Variant, RåData2 As Variant, Rådata3 As Variant
Dim UdData1 As Variant, UdData2 As Variant, UdData3 As Variant
Dim UD1 As Long, UD2 As Long, UD3 As Long
Dim I As Integer, J As Long, X As Integer, Kol As Integer, Rk As Long
UD1 = 2
UD2 = 2
UD3 = 2
RåData1 = Application.Workbooks("StamExcel.49").Sheets("Kreditkort").Range("A8").CurrentRegion
RåData2 = Application.Workbooks("StamExcel.50").Sheets("Kreditkort").Range("A8").CurrentRegion
Rådata3 = Application.Workbooks("StamExcel.51").Sheets("Kreditkort").Range("A8").CurrentRegion
Rk = UBound(RåData1, 1)
Kol = UBound(RåData1, 2)
ReDim UdData1(Rk, Kol)
ReDim UdData2(Rk, Kol)
ReDim UdData3(Rk, Kol)
For I = 1 To UBound(RåData1, 2)
UdData1(1, I) = RåData1(1, I)
Next
'Her skal der indsættes kriterier for dato og klokkeslæt (start på måneden, - større end 1. december kl. 00:00).
For J = 2 To Rk
If InStr(1, UCase(RåData1(J, 7)), "ID3456") And InStr(1, UCase(RåData1(J, 3)), "VISA/DK") Then
For X = 1 To Kol
UdData1(UD1, X) = RåData1(J, X)
Next
UD1 = UD1 + 1
End If
Next
For I = 1 To UBound(RåData2, 2)
UdData1(1, I) = RåData2(1, I)
Next
'Import af data uden kriterier for dato og klokkeslæt. Der kommer data fra 2-4 ark med samme krterier.
For J = 2 To Rk
If InStr(1, UCase(RåData2(J, 7)), "ID3456") And InStr(1, UCase(RåData2(J, 3)), "VISA/DK") Then
For X = 1 To Kol
UdData2(UD1, X) = RåData2(J, X)
Next
UD2 = UD2 + 1
End If
Next
For I = 1 To UBound(Rådata3, 2)
UdData3(1, I) = Rådata3(1, I)
Next
'Her skal der indsættes kriterier for dato og klokkeslæt (slut på måneden, - mindre end 31. december kl. 23:59).
For J = 2 To Rk
If InStr(1, UCase(Rådata3(J, 7)), "ID3456") And InStr(1, UCase(Rådata3(J, 3)), "VISA/DK") Then
For X = 1 To Kol
UdData3(UD3, X) = Rådata3(J, X)
Next
UD3 = UD3 + 1
End If
Next
Worksheets("IndsætData").Range("A1").Resize(Rk, Kol) = UdData1
Worksheets("IndsætData").Range("A1").Resize(Rk, Kol) = UdData2
Worksheets("IndsætData").Range("A1").Resize(Rk, Kol) = UdData3
End Sub
Er der nogen der har et bud på en løsning ?
Laugesen
