Hej Eksperter Jeg har en tabel (ganske mange faktisk) hvor data står i et format nogenlunde som dette: kundenr;firmanavn;co-navn;att;adresse;stednavn;postnummer-by
Jeg har brug for at samle felterne mod venstre, da mit fletteprogram ikke kan fjerne tomme linjer, så jeg får felter til: Linje1;linje2;linje3...
Jeg har forsøgt at lave noget kontrol på hvis det ene eller det andet felt er tomt så tag indhold fra her og der... men når jeg når til printlinje3-4 stykker bliver betingelserne simpelthen så kringlede at jeg ikke kan oversku hvad der sker længere... Jeg har derfor haft VBA kode der traverserer igennem række for række, felt for felt og flytter indholdet... fungerer fint på små tabeller, men går enten langsomt eller endda fejler når tabellerne bliver større (flere hundrede tusinde eller over en mio)
Har nogen en bedre løsning som måske kunne gøres i en forespørgsel i stedet for VBA eller bare en kønnere måde der vil performe bedre?
Jeg er ikke stolt af denne kode... alle mine elseif kunne nok med fordel erstattes af select case eller andet, men tror det er alle mine recordset.edit og recordset.update der får filmen til at knække...
Dim rst As Object Set rst = CurrentDb.OpenRecordset("inputabel", dbOpenDynaset)
Dim Felt1 As String, Felt2 As String, Felt3 As String, Felt4 As String, Felt5 As String, Felt6 As String, Felt7 As String, felt8 As String Dim Akk1 As Boolean, Akk2 As Boolean, Akk3 As Boolean, Akk4 As Boolean, Akk5 As Boolean, Akk6 As Boolean, Akk7 As Boolean, Akk8 As Boolean
If Akk2 Then If IsNull(Trim(rst("felt2"))) Then Felt2 = "" Else Felt2 = Trim(rst("felt2")) End If
If Akk3 Then If IsNull(Trim(rst("felt3"))) Then Felt3 = "" Else Felt3 = Trim(rst("felt3")) End If
If Akk4 Then If IsNull(Trim(rst("felt4"))) Then Felt4 = "" Else Felt4 = Trim(rst("felt4")) End If
If Akk5 Then If IsNull(Trim(rst("felt5"))) Then Felt5 = "" Else Felt5 = Trim(rst("felt5")) End If
If Akk6 Then If IsNull(Trim(rst("felt6"))) Then Felt6 = "" Else Felt6 = Trim(rst("felt6")) End If
If Akk7 Then If IsNull(Trim(rst("felt7"))) Then Felt7 = "" Else Felt7 = Trim(rst("felt7")) End If
If Akk8 Then If IsNull(Trim(rst("felt8"))) Then felt8 = "" Else felt8 = Trim(rst("felt8")) End If
If Akk1 And Felt1 = "" Then If Akk2 And Len(Trim(Felt2)) <> 0 Then Felt1 = Felt2 Felt2 = "" ElseIf Akk3 And Len(Trim(Felt3)) <> 0 Then Felt1 = Felt3 Felt3 = "" ElseIf Akk4 And Len(Trim(Felt4)) <> 0 Then Felt1 = Felt4 Felt4 = "" ElseIf Akk5 And Len(Trim(Felt5)) <> 0 Then Felt1 = Felt5 Felt5 = "" ElseIf Akk6 And Len(Trim(Felt6)) <> 0 Then Felt1 = Felt6 Felt6 = "" ElseIf Akk7 And Len(Trim(Felt7)) <> 0 Then Felt1 = Felt7 Felt7 = "" ElseIf Akk8 And Len(Trim(felt8)) <> 0 Then Felt1 = felt8 felt8 = "" End If End If
If Akk2 And Felt2 = "" Then If Akk3 And Len(Trim(Felt3)) <> 0 Then Felt2 = Felt3 Felt3 = "" ElseIf Akk4 And Len(Trim(Felt4)) <> 0 Then Felt2 = Felt4 Felt4 = "" ElseIf Akk5 And Len(Trim(Felt5)) <> 0 Then Felt2 = Felt5 Felt5 = "" ElseIf Akk6 And Len(Trim(Felt6)) <> 0 Then Felt2 = Felt6 Felt6 = "" ElseIf Akk7 And Len(Trim(Felt7)) <> 0 Then Felt2 = Felt7 Felt7 = "" ElseIf Akk8 And Len(Trim(felt8)) <> 0 Then Felt2 = felt8 felt8 = "" End If End If
If Akk3 And Felt3 = "" Then If Akk4 And Len(Trim(Felt4)) <> 0 Then Felt3 = Felt4 Felt4 = "" ElseIf Akk5 And Len(Trim(Felt5)) <> 0 Then Felt3 = Felt5 Felt5 = "" ElseIf Akk6 And Len(Trim(Felt6)) <> 0 Then Felt3 = Felt6 Felt6 = "" ElseIf Akk7 And Len(Trim(Felt7)) <> 0 Then Felt3 = Felt7 Felt7 = "" ElseIf Akk8 And Len(Trim(felt8)) <> 0 Then Felt3 = felt8 felt8 = "" End If End If
If Akk4 And Felt4 = "" Then If Akk5 And Len(Trim(Felt5)) <> 0 Then Felt4 = Felt5 Felt5 = "" ElseIf Akk6 And Len(Trim(Felt6)) <> 0 Then Felt4 = Felt6 Felt6 = "" ElseIf Akk7 And Len(Trim(Felt7)) <> 0 Then Felt4 = Felt7 Felt7 = "" ElseIf Akk8 And Len(Trim(felt8)) <> 0 Then Felt4 = felt8 felt8 = "" End If End If
If Akk5 And Felt5 = "" Then If Akk6 And Len(Trim(Felt6)) <> 0 Then Felt5 = Felt6 Felt6 = "" ElseIf Akk7 And Len(Trim(Felt7)) <> 0 Then Felt5 = Felt7 Felt7 = "" ElseIf Akk8 And Len(Trim(felt8)) <> 0 Then Felt5 = felt8 felt8 = "" End If End If
If Akk6 And Felt6 = "" Then If Akk7 And Len(Trim(Felt7)) <> 0 Then Felt6 = Felt7 Felt7 = "" ElseIf Akk8 And Len(Trim(felt8)) <> 0 Then Felt6 = felt8 felt8 = "" End If End If
If Akk7 And Felt7 = "" Then If Akk8 And Len(Trim(felt8)) <> 0 Then Felt7 = felt8 felt8 = "" End If End If
rst.Edit If Akk1 Then rst("felt1") = Left(Felt1, 55) If Akk2 Then rst("felt2") = Left(Felt2, 55) If Akk3 Then rst("felt3") = Left(Felt3, 55) If Akk4 Then rst("felt4") = Left(Felt4, 55) If Akk5 Then rst("felt5") = Left(Felt5, 55) If Akk6 Then rst("felt6") = Left(Felt6, 55) If Akk7 Then rst("felt7") = Left(Felt7, 55) If Akk8 Then rst("felt8") = Left(Felt8, 55) rst.Update rst.MoveNext Loop
' Luk og sluk rst.Close Set rst = Nothing CurrentDb.Close End Function
----- Option Compare Database Option Explicit Option Base 1
Sub Test() Dim Db As DAO.Database Dim DummyRst As DAO.Recordset Dim b(8) As Boolean Dim i As Integer Dim j As Integer Dim a As Integer
Set Db = CurrentDb Set DummyRst = Db.OpenRecordset("Tabel5", dbOpenDynaset) With DummyRst If Not .EOF Then Do 'Tæl ikke-tomme a = 0 For i = 1 To 8 b(i) = False If Not IsNull(.Fields("Felt" & i)) Then If .Fields("Felt" & i) <> "" Then b(i) = True a = a + 1 End If End If Next i
'Mindst ét tomt felt If a > 0 And a < 8 Then .Edit
'Flyt j = 0 For i = 1 To 8 If b(i) Then j = j + 1 .Fields("Felt" & j) = .Fields("Felt" & i) End If Next i
'Nulstil resten If a < 8 Then For i = a + 1 To 8 .Fields("Felt" & i) = "" Next i End If
.Update End If
.MoveNext Loop Until .EOF End If .Close End With Set DummyRst = Nothing Set Db = Nothing End Sub ------
Hej fdata En langt, langt kønnere udgave af min skrammelkode, 1000 tak for det :D Men stadig med en .edit og .update for hver eneste række, så jeg er bange for performance ikke er meget bedre? :/
Dim Records As DAO.Recordset Dim Field As DAO.Field
Dim Index As Integer
Set Records = CurrentDb.OpenRecordset("inputabel")
While Not Records.EOF Index = 0 Records.Edit For Each Field In Records.Fields If Trim(Nz(Field.Value)) <> "" Then If Records.Fields(Index).Name <> Field.Name Then Records.Fields(Index).Value = Trim(Field.Value) End If Index = Index + 1 End If Next For Index = Index To Records.Fields.Count - 1 If Not IsNull(Records.Fields(Index).Value) Then Records.Fields(Index).Value = Null End If Next Records.Update Records.MoveNext Wend Records.Close
Jeg er godt nok imponeret over hvor meget min længe skraldkode kan koges ned :D Men jeg ender desværre stadig med en million Records.Edit og Records.Update
Jeg tænker om man kan lave en en funktion til en forespørgsel: Linje1: FindLinje(1; [Felt1]; [Felt2]; [Felt3]; [Felt4]; [Felt5]; [Felt6]; [Felt7]; [Felt8]) Linje2: FindLinje(2; [Felt1]; [Felt2]; [Felt3]; [Felt4]; [Felt5]; [Felt6]; [Felt7]; [Felt8]) Linje3: FindLinje(3; [Felt1]; [Felt2]; [Felt3]; [Felt4]; [Felt5]; [Felt6]; [Felt7]; [Felt8]) ...
Public Function FindLinje(LinjeNr as integer, Felt1 as String, Felst2 as String...) FindLinje = indholdet fra linje nr, der har indhold End Function
Næppe, for da skal den jo for hver eneste record kalde FindLinje.
Hvis det kun er få poster, der har tomme felter, kunne opgaven optimeres til at checke dette og kun opdatere de poster, hvor der er mindst ét tomt felt:
Public Function Akkumuler()
Dim Records As DAO.Recordset Dim Field As DAO.Field
Dim Index As Integer
Set Records = CurrentDb.OpenRecordset("inputabel")
While Not Records.EOF Index = 0 ' Undersøg om mindst ét felt er tomt. For Each Field In Records.Fields If Trim(Nz(Field.Value)) = "" Then Index = -1 Exit For End If Next
If Index <> 0 Then ' Ingen tomme felter. Intet at opdatere. Else Records.Edit For Each Field In Records.Fields If Trim(Nz(Field.Value)) <> "" Then If Records.Fields(Index).Name <> Field.Name Then Records.Fields(Index).Value = Trim(Field.Value) End If Index = Index + 1 End If Next For Index = Index To Records.Fields.Count - 1 If Not IsNull(Records.Fields(Index).Value) Then Records.Fields(Index).Value = Null End If Next Records.Update End If Records.MoveNext Wend Records.Close
Jeg tænker bare der performance-mæssigt ikke er nogen problemer med at kalde en beregning på tekst 1 mio gange - Det er jo ikke et problem med left, right og alle andre funktioner... problemet - tror jeg - ligger i at åbne og lukke tabellen for redigering 1 mio gange... og det vil jeg jo komme udenom ved at ligge det i en Forespørgsel
Public Function FindLinje(LinjeNr As Integer, Felt1 As String, Felt2 As String, Felt3 As String, Felt4 As String, Felt5 As String, Felt6 As String, Felt7 As String, Felt8 As String) As String
If Len(Nz(Felt1)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt1 Exit Function Else LinjeNr = LinjeNr - 1 End If End If If Len(Nz(Felt2)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt2 Exit Function Else LinjeNr = LinjeNr - 1 End If End If If Len(Nz(Felt3)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt3 Exit Function Else LinjeNr = LinjeNr - 1 End If End If If Len(Nz(Felt4)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt4 Exit Function Else LinjeNr = LinjeNr - 1 End If End If If Len(Nz(Felt5)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt5 Exit Function Else LinjeNr = LinjeNr - 1 End If End If If Len(Nz(Felt6)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt6 Exit Function Else LinjeNr = LinjeNr - 1 End If End If If Len(Nz(Felt7)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt7 Exit Function Else LinjeNr = LinjeNr - 1 End If End If If Len(Nz(Felt8)) > 0 Then If LinjeNr = 1 Then FindLinje = Felt8 Exit Function Else LinjeNr = LinjeNr - 1 End If End If FindLinje = ""
Ved ikke lige hvorfor al indryk bliver fjernet, men når man har læst de første 8 linjer af koden, er det egentlig bare det samme for hver mulig printlinje... Det ligner skrald, men det virker ret godt
When I run the code from query, the table is only opened and edited once. (created)
If I run the code from vba recordset.edit, it's opened for editing once per record = around one million times, and my computer runs out of memmory (aparently not just ram)
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.
