23. januar 2018 - 09:51Der er
9 kommentarer og 1 løsning
automatisk behandling af rådata
Hej
Jeg får 4 gange årligt en masse data, som jeg gerne vil have excel hurtig behandler for mig så jeg får et output som er nemt at overskue. Rådaten sætter jeg ind i et ”rådata” ark og herefter skal den automatisk gøre følgende ting for mig:
I arket ”rådata 1” vil jeg først gerne at den kigger på kolonne A ”Expiration date”, her skal den farve alle de datoer der ligger før d. 1/1-2018 røde.
Så vil jeg gerne at den overføre navnene fra kolonnen c ”lev.” og den tilhørende dato til den liste på ark ”udløb pr. 1 jan 2018” der matcher det navn der står i kolonne b ”certificate” ved siden af. Altså står der halal i kolonnen b skal den tage navnet i kolonne c og dato i kolonne a og overføre til ark ”udløb pr. 1 jan 2018” under Halal --> leverandør og certifikat udløb. Stadig kun på de datoer der er røde.
Er det noget der kan lade sig gøre med VBA?? Håber virkelig der er nogen der kan hjælpe mig:)
Har lige tid til den ene: Betinget formattering: = år(celleA)<2018 ""I arket ”rådata 1” vil jeg først gerne at den kigger på kolonne A ”Expiration date”, her skal den farve alle de datoer der ligger før d. 1/1-2018 røde.""
Du kan anvende "Filter" på din oprindelige ark, Filtrer på kolonne "C" lev. for f. eks.halal, og på kolonne "A" hvor du først filtrerer på alle, og derefter sletter de datoer der ikke skal vises.
Det kan sikker opstilles med en formel for kolonne "A"
Hej Therge Jeg har lavet en VBA-løsning, der ser ud til at fungere. Makroen arbejder ud fra data i det aktive ark. Kopier koden ind i et VBA-modul. Bemærk at du i koden kan ændre udløbsdatoen og navnet på det ark, hvori du opsamler data'ene.
Sub SorterRaadata()
Dim Datelimit As String, ReportSht As Worksheet, StartCl As Range, i As Integer Dim LFF() Dim Halal() Dim Kosher() Dim Miljo() Dim Okologi() Dim RSPO()
Application.ScreenUpdating = False Datelimit = "1-1-2018" '<<<<-----Her kan du ændre certifikatudløbsdata
Set ReportSht = ThisWorkbook.Worksheets("pr. 1 jan 2018") '<<<<-----Her kan du ændre navnet på det tilhørende ark
'---------------------------------- 'Lav en liste for hver certifikattype med de artikler/varer, der opfylder datokriteriet
ReDim LFF(0 To 1, 0 To 0) ReDim Halal(0 To 1, 0 To 0) ReDim Kosher(0 To 1, 0 To 0) ReDim Miljo(0 To 1, 0 To 0) ReDim Okologi(0 To 1, 0 To 0) ReDim RSPO(0 To 1, 0 To 0)
ActiveSheet.Cells(2, 1).Select
While ActiveCell.Value <> ""
If DateValue(ActiveCell.Value) < DateValue(Datelimit) Then ActiveCell.Interior.ColorIndex = 3 Select Case True
Case ActiveCell.Offset(0, 1).Value Like ("Ledelse*") ReDim Preserve LFF(0 To 1, 0 To UBound(LFF, 2) + 1) LFF(0, UBound(LFF, 2)) = ActiveCell.Value LFF(1, UBound(LFF, 2)) = ActiveCell.Offset(0, 2).Value
Case ActiveCell.Offset(0, 1).Value Like ("Halal*") ReDim Preserve Halal(0 To 1, 0 To UBound(Halal, 2) + 1) Halal(0, UBound(Halal, 2)) = ActiveCell.Value Halal(1, UBound(Halal, 2)) = ActiveCell.Offset(0, 2).Value
Case ActiveCell.Offset(0, 1).Value Like ("Kosher*") ReDim Preserve Kosher(0 To 1, 0 To UBound(Kosher, 2) + 1) Kosher(0, UBound(Kosher, 2)) = ActiveCell.Value Kosher(1, UBound(Kosher, 2)) = ActiveCell.Offset(0, 2).Value
Case ActiveCell.Offset(0, 1).Value Like ("Miljø*") ReDim Preserve Miljo(0 To 1, 0 To UBound(Miljo, 2) + 1) Miljo(0, UBound(Miljo, 2)) = ActiveCell.Value Miljo(1, UBound(Miljo, 2)) = ActiveCell.Offset(0, 2).Value
Case ActiveCell.Offset(0, 1).Value Like ("Økologi*") ReDim Preserve Okologi(0 To 1, 0 To UBound(Okologi, 2) + 1) Okologi(0, UBound(Okologi, 2)) = ActiveCell.Value Okologi(1, UBound(Okologi, 2)) = ActiveCell.Offset(0, 2).Value
Case ActiveCell.Offset(0, 1).Value Like ("RSPO*") ReDim Preserve RSPO(0 To 1, 0 To UBound(RSPO, 2) + 1) RSPO(0, UBound(RSPO, 2)) = ActiveCell.Value RSPO(1, UBound(RSPO, 2)) = ActiveCell.Offset(0, 2).Value End Select End If ActiveCell.Offset(1, 0).Select Wend
'----------------------------------------- 'Skriv listerne i de relevante kolonner i ReportSht ReportSht.Activate Set StartCl = Cells(2, 1).End(xlDown) For i = 1 To UBound(LFF, 2) StartCl.Offset(i, 0).Value = LFF(1, i) StartCl.Offset(i, 2).Value = LFF(0, i) Next
Set StartCl = Cells(2, 5).End(xlDown) For i = 1 To UBound(Halal, 2) StartCl.Offset(i, 0).Value = Halal(1, i) StartCl.Offset(i, 2).Value = Halal(0, i) Next
Set StartCl = Cells(2, 9).End(xlDown) For i = 1 To UBound(Kosher, 2) StartCl.Offset(i, 0).Value = Kosher(1, i) StartCl.Offset(i, 2).Value = Kosher(0, i) Next
Set StartCl = Cells(2, 13).End(xlDown) For i = 1 To UBound(Miljo, 2) StartCl.Offset(i, 0).Value = Miljo(1, i) StartCl.Offset(i, 2).Value = Miljo(0, i) Next
Set StartCl = Cells(2, 17).End(xlDown) For i = 1 To UBound(Okologi, 2) StartCl.Offset(i, 0).Value = Okologi(1, i) StartCl.Offset(i, 2).Value = Okologi(0, i) Next
Set StartCl = Cells(2, 21).End(xlDown) For i = 1 To UBound(RSPO, 2) StartCl.Offset(i, 0).Value = RSPO(1, i) StartCl.Offset(i, 2).Value = RSPO(0, i) Next
Jeg kan få det til at virke med at den markere datoerne røde, men så ikke mere. Så kommer den med en fejlbox "Type mismatch"..??? Kan ikke se hvor det går galt??
Hej Det er fordi der er rod i dine data i rådataarket. Når du kommer ned til række 2343 står der ikke længere datoer i kolonne A, men producenter eller leverandører. Desuden så anbringer jeg VBA-koden i et kodemodul, ikke i et regneark - men jeg ved ikke om det har nogen betydning... Husk at sørge for at dit rådataark er det aktive ark, før du kører koden. Vi kan tilføje lidt fejlfinding til koden, så du kan finde hvor det går galt:
While ActiveCell.Value <> "" On Error GoTo msg: If DateValue(ActiveCell.Value) < DateValue(Datelimit) Then Indsæt linjen med fed mellem de to andre linjer
Exit Sub msg: MsgBox "Fejl i celle " & ActiveCell.Address & vbCr & "Indhold: " & ActiveCell.Value End Sub Indsæt linjerne med fed lige før "End Sub"
Der skal ikke være data fra række 2343 af. Mine rådata går kun til 2342. Det er data den sætter ind når jeg afspiller makroen, men kan se at det ligner det data jeg gerne vil have flyttet til "pr. 1 jan 2018" arket.
Jeg er ikke stærk nok til excel så jeg kan få den der fejlfinding kode til at virke. Noget andet jeg kan gøre??
I det oprindelige regneark, du delte via Dropbox (certifikatudløb 2018.xlsx) er der data til og med række 3551. Fra række 2342 har de alle datoen 11-11-1111. Grunden til at du ikke kan se dem er, at din tabel er filtreret. Klik på filtersymbolet ved overskriften "Certificate" i celle B1. Når jeg fjerner de fejlagtigt indsatte data og kører makroen, fungerer det problemfrit. Men det kræver, at du kopierer koden ind i et Kodemodul og IKKE ind på 'Kodesiden' i dit regneark, som du havde gjort. Jeg har testet begge situationer. Det fejler, hvis man ikke gør, som jeg skriver.
Jeg har fået det til at virke nu, ved at gøre som du beskriver. Jeg vil gerne have tilføjet en ekstra ting den skal gøre når jeg kører makroen, men kan simpelthen ikke regne ud hvad det er jeg skal tilføje?? Jeg vil gerne at den tager producent navnet fra kolonne D fra "Rådata" arket og flytter den til kolonnen B i "pr 1 jan. 2018" arket. E det noget du kan hjælpe med??
Hej Jeg har udvidet mine arrays, så de også medtager producenten. Erstat den relevante del af den gamle kode med dette:
'---------------------------------- 'Lav en liste for hver certifikattype med de leverandører + producenter, der opfylder datokriteriet
ReDim LFF(0 To 2, 0 To 0) ReDim Halal(0 To 2, 0 To 0) ReDim Kosher(0 To 2, 0 To 0) ReDim Miljo(0 To 2, 0 To 0) ReDim Okologi(0 To 2, 0 To 0) ReDim RSPO(0 To 2, 0 To 0)
ActiveSheet.Cells(2, 1).Select
While ActiveCell.Value <> ""
If DateValue(ActiveCell.Value) < DateValue(Datelimit) Then ActiveCell.Interior.ColorIndex = 3 Select Case True
Case ActiveCell.Offset(0, 1).Value Like ("Ledelse*") ReDim Preserve LFF(0 To 2, 0 To UBound(LFF, 2) + 1) LFF(0, UBound(LFF, 2)) = ActiveCell.Value LFF(1, UBound(LFF, 2)) = ActiveCell.Offset(0, 2).Value LFF(2, UBound(LFF, 2)) = ActiveCell.Offset(0, 3).Value
Case ActiveCell.Offset(0, 1).Value Like ("Halal*") ReDim Preserve Halal(0 To 2, 0 To UBound(Halal, 2) + 1) Halal(0, UBound(Halal, 2)) = ActiveCell.Value Halal(1, UBound(Halal, 2)) = ActiveCell.Offset(0, 2).Value Halal(2, UBound(Halal, 2)) = ActiveCell.Offset(0, 3).Value
Case ActiveCell.Offset(0, 1).Value Like ("Kosher*") ReDim Preserve Kosher(0 To 2, 0 To UBound(Kosher, 2) + 1) Kosher(0, UBound(Kosher, 2)) = ActiveCell.Value Kosher(1, UBound(Kosher, 2)) = ActiveCell.Offset(0, 2).Value Kosher(2, UBound(Kosher, 2)) = ActiveCell.Offset(0, 3).Value
Case ActiveCell.Offset(0, 1).Value Like ("Miljø*") ReDim Preserve Miljo(0 To 2, 0 To UBound(Miljo, 2) + 1) Miljo(0, UBound(Miljo, 2)) = ActiveCell.Value Miljo(1, UBound(Miljo, 2)) = ActiveCell.Offset(0, 2).Value Miljo(2, UBound(Miljo, 2)) = ActiveCell.Offset(0, 3).Value
Case ActiveCell.Offset(0, 1).Value Like ("Økologi*") ReDim Preserve Okologi(0 To 2, 0 To UBound(Okologi, 2) + 1) Okologi(0, UBound(Okologi, 2)) = ActiveCell.Value Okologi(1, UBound(Okologi, 2)) = ActiveCell.Offset(0, 2).Value Okologi(2, UBound(Okologi, 2)) = ActiveCell.Offset(0, 3).Value
Case ActiveCell.Offset(0, 1).Value Like ("RSPO*") ReDim Preserve RSPO(0 To 2, 0 To UBound(RSPO, 2) + 1) RSPO(0, UBound(RSPO, 2)) = ActiveCell.Value RSPO(1, UBound(RSPO, 2)) = ActiveCell.Offset(0, 2).Value RSPO(2, UBound(RSPO, 2)) = ActiveCell.Offset(0, 3).Value End Select End If ActiveCell.Offset(1, 0).Select Wend
'----------------------------------------- 'Skriv listerne i de relevante kolonner i ReportSht ReportSht.Activate Set StartCl = Cells(2, 1).End(xlDown) For i = 1 To UBound(LFF, 2) StartCl.Offset(i, 0).Value = LFF(1, i) StartCl.Offset(i, 1).Value = LFF(2, i) StartCl.Offset(i, 2).Value = LFF(0, i) Next
Set StartCl = Cells(2, 6).End(xlDown) For i = 1 To UBound(Halal, 2) StartCl.Offset(i, 0).Value = Halal(1, i) StartCl.Offset(i, 1).Value = Halal(2, i) StartCl.Offset(i, 2).Value = Halal(0, i) Next
Set StartCl = Cells(2, 11).End(xlDown) For i = 1 To UBound(Kosher, 2) StartCl.Offset(i, 0).Value = Kosher(1, i) StartCl.Offset(i, 1).Value = Kosher(2, i) StartCl.Offset(i, 2).Value = Kosher(0, i) Next
Set StartCl = Cells(2, 16).End(xlDown) For i = 1 To UBound(Miljo, 2) StartCl.Offset(i, 0).Value = Miljo(1, i) StartCl.Offset(i, 1).Value = Miljo(2, i) StartCl.Offset(i, 2).Value = Miljo(0, i) Next
Set StartCl = Cells(2, 21).End(xlDown) For i = 1 To UBound(Okologi, 2) StartCl.Offset(i, 0).Value = Okologi(1, i) StartCl.Offset(i, 1).Value = Okologi(2, i) StartCl.Offset(i, 2).Value = Okologi(0, i) Next
Set StartCl = Cells(2, 26).End(xlDown) For i = 1 To UBound(RSPO, 2) StartCl.Offset(i, 0).Value = RSPO(1, i) StartCl.Offset(i, 1).Value = RSPO(2, i) StartCl.Offset(i, 2).Value = RSPO(0, i) Next
Vær opmærksom på, at den kode, du har skrevet ved hjælp af makro-recorderen bruger absolutte cellereferencer. Dvs kører du den på et andet datasæt med et andet antal poster, så får du et noget uforudsigeligt resultat.
Det er fantastisk. Det virker lige som jeg ønsker det. Tusind tak for din hjælp, det sætter jeg pris på;)
Synes godt om
Ny brugerNybegynder
Din løsning...
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.
