28. maj 2008 - 10:26Der er
16 kommentarer og 1 løsning
teste om 1 tal er brugt på flere at gruppehold
I kolonne D står der tal fra 1 - 49 der angiver hold. Det samme tal bliver brugt flere gange.
I kolonne G står der næsten altid noget, men ikke altid. Det tal der står i kolonne G er typisk fra 100-199
Tallet i kolonne G må gerne anvendes flere gange, men må kun anvendes på et unikt tal fra kolonne D.
dvs. tallet 101 må gerne stå i kolonne G i mange linier men der SKAL stå det samme tal f.eks. 10 i kolonne D i alle disse linier.
Er det ikke tilfældet skal der poppe en meddelelse op som fortæller hvilket linienr. der er gal med. (gerne incl. den tekst der står i kolonne A i pågældende linie.
Hvis det kan lade sig gøre den meget gerne skrive: Fejl: tekst fra kolonne A tekst kolonne D TEkst kolonne G tekst fra kolonne A tekst kolonne D TEkst kolonne G og så videre
det optimale ville være at fejlmeddelesen sorterede efter nr i kol. D Sådan at den viste fejlen gruppevis. Aner ikke om det kan lade sig gøre, men hvis man ikke spørger, så finder man heller ikke ud af det :-)
Forslag med en lidt anden visualisering - men prøv at se på det...
Rem Ved uoverenstemmelser opbygges en kolonne til højre med Holdnr i første række Rem og rækkenr neden under. Rem Hold er anført i rækkefølge - ej fejlmeldte holdnr er ikke anført - derfor Rem tomme kolonner - fra venstre mod højre Rem Koden indsættes i aktuelle ark
Const startRæk = 1 'kan justeres Dim antalRæk, antalKol Public Sub TestAfNr() Dim gnr, dnr
Application.ScreenUpdating = False
Rem Find antal rækker antalRæk = ActiveCell.SpecialCells(xlLastCell).Row antalKol = ActiveCell.SpecialCells(xlLastCell).Column
Rem Gennenløb af rækker indtil sidste række For ræk = startRæk To antalRæk gnr = Cells(ræk, 7) dnr = Cells(ræk, 4)
Rem Er gNr udfyldt og holdnr ikke checket If gnr <> "" And Cells(ræk, 4).Interior.ColorIndex = xlNone Then checkOk gnr, dnr, ræk End If Next ræk
Application.ScreenUpdating = True
Rem Gennemløb afsluttet - hvis evt. fejl MsgBox ("Gennemløb afsluttet") End Sub Private Sub checkOk(gnr, holdNr, aktuelleRække) Dim aGnr, aDnr, aktuelleKol, fejlRæk, flag As Boolean
flag = False
If aktuelleRække < antalRæk Then For ræk = aktuelleRække + 1 To antalRæk aGnr = Cells(ræk, 7) aDnr = Cells(ræk, 4)
If aGnr = gnr And Cells(ræk, 4).Interior.ColorIndex = xlNone Then Rem Hvis ens Gnr - så check om Holdnr er ens If aDnr <> holdNr Then Rem Beregn kolonne iflg. Holdnr aktuelleKol = antalKol + holdNr Rem Find ledige række i denne kolonne For r = 2 To 65000 If Cells(r, aktuelleKol) = "" Then fejlRæk = r Exit For End If Next r Rem gem række med uoverensstemmelse i kolonne for holdnr If flag = False Then Rem udgangsrækken markeres Cells(fejlRæk, aktuelleKol) = aktuelleRække fejlRæk = fejlRæk + 1 flag = True Cells(aktuelleRække, 4).Interior.ColorIndex = 6 End If
Cells(fejlRæk, aktuelleKol) = ræk If Cells(1, aktuelleKol) = "" Then Cells(1, aktuelleKol) = holdNr Cells(1, aktuelleKol).Font.Bold = True End If
Rem marker HoldNr (dNnr-cellen) som testet Cells(ræk, 4).Interior.ColorIndex = 6 End If End If Next ræk End If End Sub
Så har jeg testet lidt på koden. Det viser jo fint hvor den er galt, og det meget nemt at finde fejlene. Men jeg vil alligevel høre om der kan rettes lidt i koden.
a) når man har rettet fejlene, bliver farvekoden ved med at være gul, også selvom man kører koden igen. Kunne man evt. slette alle farvekoder inden gennemløbet.
b) da jeg har en del linier den løber igennem kunne jeg rigtig godt tænke mig at den lavede en besked med: Der er fejl i linierne tekst i kol. A + tekst i kol G do do do
Giv signal, hvis alle fejllinier ikke kan vises i msgbox'en - evt. skal der være flere pr. linie.
Rem Version 2 Rem ========= Rem Ved uoverenstemmelser opbygges en kolonne til højre med Holdnr i første række Rem og rækkenr neden under. Rem Hold er anført i rækkefølge - ej fejlmeldte holdnr er ikke anført - derfor Rem tomme kolonner - fra venstre mod højre Rem Koden indsættes i aktuelle ark
Const startRæk = 1 'kan justeres Dim antalRæk, antalKol Public Sub TestAfNr() Dim gnr, dnr
Rem Find antal rækker antalRæk = ActiveCell.SpecialCells(xlLastCell).Row antalKol = ActiveCell.SpecialCells(xlLastCell).Column
Rem Slet tidligere farve-markeringer Columns("D").Select Selection.Cells.Interior.ColorIndex = xlNone
Application.ScreenUpdating = False Rem Gennenløb af rækker indtil sidste række For ræk = startRæk To antalRæk gnr = Cells(ræk, 7) dnr = Cells(ræk, 4)
Rem Er gNr udfyldt og holdnr ikke checket If gnr <> "" And Cells(ræk, 4).Interior.ColorIndex = xlNone Then checkOk gnr, dnr, ræk End If Next ræk
Application.ScreenUpdating = True
Rem Gennemløb afsluttet - hvis evt. fejl opbygMsgBox
End Sub Private Sub checkOk(gnr, holdNr, aktuelleRække) Dim aGnr, aDnr, aktuelleKol, fejlRæk, flag As Boolean
flag = False
If aktuelleRække < antalRæk Then For ræk = aktuelleRække + 1 To antalRæk aGnr = Cells(ræk, 7) aDnr = Cells(ræk, 4)
If aGnr = gnr And Cells(ræk, 4).Interior.ColorIndex = xlNone Then Rem Hvis ens Gnr - så check om Holdnr er ens If aDnr <> holdNr Then Rem Beregn kolonne iflg. Holdnr aktuelleKol = antalKol + holdNr Rem Find ledige række i denne kolonne For r = 2 To 65000 If Cells(r, aktuelleKol) = "" Then fejlRæk = r Exit For End If Next r Rem gem række med uoverensstemmelse i kolonne for holdnr If flag = False Then Rem udgangsrækken markeres Cells(fejlRæk, aktuelleKol) = aktuelleRække fejlRæk = fejlRæk + 1 flag = True Cells(aktuelleRække, 4).Interior.ColorIndex = 6 End If
Cells(fejlRæk, aktuelleKol) = ræk If Cells(1, aktuelleKol) = "" Then Cells(1, aktuelleKol) = holdNr Cells(1, aktuelleKol).Font.Bold = True End If
Rem marker HoldNr (dNnr-cellen) som testet Cells(ræk, 4).Interior.ColorIndex = 6 End If End If Next ræk End If End Sub Private Sub opbygMsgBox() Dim mBox, kol, ræk, holdNr mBox = ""
Rem gennemgå kolonner med evt. fejlmarkeringer - pr. hold For kol = antalKol + 1 To antalKol + 49 If Cells(1, kol) <> "" Then holdNr = Cells(1, kol) mBox = "Fejl - HoldNr.: " & CStr(holdNr) + vbCr For ræk = 2 To 65000 If Cells(ræk, kol) = "" Then Exit For Else fejlrække = CStr(ræk) + " " + Cells(ræk, 1) + " " + CStr(Cells(ræk, 7)) + vbCr mBox = mBox + fejlrække End If Next ræk End If
a) Nu blev den noget langsom om at lave tjekket, desværre. Det kan jeg god leve med, men som altid. Jo hurtigere jo bedre. :-) Koden er meget svære end jeg forstår, men dit forslag nr. 1 var, næsten som den skulle være, hvis blot man kunne få message boksen med.
b) Den tekst den skrive i messageboksen er ikke helt korrekt. Den skrive altid den tekst der stå i celle a2+a3+osv alt efter hvor mange fejl der er.
Den skal helst skrive den tekst som står i de linier som har fejlen.
Slet manuelt evt. fejlkolonnerne - hvis dette ikke er gjort. Når jeg kører kan jeg umiddelbart ikke se at hastigheden er ændret.
Rem Version 3 Rem ========= Rem Ved uoverenstemmelser opbygges en kolonne til højre med Holdnr i første række Rem og rækkenr neden under. Rem Hold er anført i rækkefølge - ej fejlmeldte holdnr er ikke anført - derfor Rem tomme kolonner - fra venstre mod højre Rem Koden indsættes i aktuelle ark
Const startRæk = 1 'kan justeres Dim antalRæk, antalKol Public Sub TestAfNr() Dim gnr, dnr
Application.ScreenUpdating = False
Rem Find antal rækker antalRæk = ActiveCell.SpecialCells(xlLastCell).Row antalKol = ActiveCell.SpecialCells(xlLastCell).Column
Rem Slet tidligere farve-markeringer Columns("D").Select Selection.Cells.Interior.ColorIndex = xlNone
Rem Gennenløb af rækker indtil sidste række For ræk = startRæk To antalRæk gnr = Cells(ræk, 7) dnr = Cells(ræk, 4)
Rem Er gNr udfyldt og holdnr ikke checket If gnr <> "" And Cells(ræk, 4).Interior.ColorIndex = xlNone Then checkOk gnr, dnr, ræk End If Next ræk
Rem Gennemløb afsluttet - hvis evt. fejl opbygMsgBox
Application.ScreenUpdating = True End Sub Private Sub checkOk(gnr, holdNr, aktuelleRække) Dim aGnr, aDnr, aktuelleKol, fejlRæk, flag As Boolean
flag = False
If aktuelleRække < antalRæk Then For ræk = aktuelleRække + 1 To antalRæk aGnr = Cells(ræk, 7) aDnr = Cells(ræk, 4)
If aGnr = gnr And Cells(ræk, 4).Interior.ColorIndex = xlNone Then Rem Hvis ens Gnr - så check om Holdnr er ens If aDnr <> holdNr Then Rem Beregn kolonne iflg. Holdnr aktuelleKol = antalKol + holdNr Rem Find ledige række i denne kolonne For r = 2 To 65000 If Cells(r, aktuelleKol) = "" Then fejlRæk = r Exit For End If Next r Rem gem række med uoverensstemmelse i kolonne for holdnr If flag = False Then Rem udgangsrækken markeres Cells(fejlRæk, aktuelleKol) = aktuelleRække fejlRæk = fejlRæk + 1 flag = True Cells(aktuelleRække, 4).Interior.ColorIndex = 6 End If
Cells(fejlRæk, aktuelleKol) = ræk If Cells(1, aktuelleKol) = "" Then Cells(1, aktuelleKol) = holdNr Cells(1, aktuelleKol).Font.Bold = True End If
Rem marker HoldNr (dNnr-cellen) som testet Cells(ræk, 4).Interior.ColorIndex = 6 End If End If Next ræk End If End Sub Private Sub opbygMsgBox() Dim mBox, kol, ræk, holdNr, fRækNr mBox = ""
Rem gennemgå kolonner med evt. fejlmarkeringer - pr. hold For kol = antalKol + 1 To antalKol + 49 If Cells(1, kol) <> "" Then holdNr = Cells(1, kol) mBox = "Fejl - HoldNr.: " & CStr(holdNr) + vbCr For ræk = 2 To 65000 If Cells(ræk, kol) = "" Then Exit For Else fRækNr = Cells(ræk, kol) fejlrække = CStr(fRækNr) + ": " + Cells(fRækNr, 1) + " " + CStr(Cells(fRækNr, 7)) + vbCr mBox = mBox + fejlrække End If Next ræk End If Next kol
jep. Nu funker det, men der er dog en lille mærkelig fejl. Hvis det er et numerisk tal der står i kolonne A og ikke en tekst, så går den ned. Det er ikke tit det sker, men én gang er jo nok.
Hastigheden var lidt sløv hos mig stadig, men da jeg ændrede den til "kun" at løbe 500 linier igennem, kører den perfekt.
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.
