VBA vs Formel

[Wastl]

Hallo,

langsam ist da ganz normal.
Du hast eine Tabelle mit 50x 24.000 Zellen und du suchst in verschiedenen zellen werte zusammen die du dann in je 5 Zellen pro Zeile schreibst.
Jeder Schreibvorgang dauert zeit x, wobei es quasi egal ist, ob ich eine Zelle fülle oder eine ganze Tabelle.

Was du tun musst:
Lege dir eine Variable an - Alle - und fülle sie mit dem Inhalt der Tabelle "Alle"
Alle = ThisWorkbook.Sheets("Alle").UsedRange

dadurch ist loLetzte auch klar:
loLetzte = UBound(Alle)

nun haste 2 Möglichkeiten: entweder, du baust dir eine Ausgabevariable die du dann langsam mit der schleife füllst oder du machst das ebenfalls in "Alle"
         If IsDate(Alle(i, 20)) Then Alle(i, 46) = Year(Alle(i, 20)) & "/" & Format(Month(Alle(i, 20)), "mm") Else Alle(i, 46) = "n.d."
         Debug.Print "Alle(i,46)=" & Alle(i, 46)

Wenn dann alles fertig berechnet und gesammelt ist, schreibst du das aufeinmal an den gewünschten Platz.
Und nur dieser Eine Schreibvorgang benötigt Zeit.

Ergänzung
Da dein Listen3 leer ist entfällt die Suche danach, aber ich speichere das auch in einem Feld, kann dann zwar nicht mit Suchen arbeiten, sondern mit einer Schleife, aber da alles im Speicher, geht das fix

[losgehts]

Hallo,

mir ist nebenbei aufgefallen, dass man ein Datum (als Text) in der Formatierung 2018/03 einfach so erzeugen kann:

Code:

Format(  DeinDatum  ,"yyyy\/mm")

auch das spart Zugriffe (wobei das arbeiten im Array anstatt auf dem Tabellenblatt sich deutlicher auswirken sollte).

Achtung,
ich glaube das hier:

Code:

Format((Int(Month(.Range("T" & i)) / 3)), "MM")

ergibt falsche Zahlen.

Wie wäre es mit
Format(DatePart("q", a), "00")

Grüße, Ulrich

[snb]

Ich glaube nicht das die Besipieldatei  die reale Dateie ähnlich ist: column h is leer, sheet Listen3 ist leer. ??

Bitter erstelle ein Muster wie das Ergebnis aussehen sollte.

Vielleicht ein Pivottable ?

[Wastl]

das finde ich bemerkenswert

mir ist nebenbei aufgefallen, dass man ein Datum (als Text) in der Formatierung 2018/03 einfach so erzeugen kann:
Code:

Code:

Format(  DeinDatum  ,"yyyy\/mm")

das funktioniert auch innerhalb Excel

PHP-Code:

=TEXT(BD12;"JJJJ\/MM") 


und diese Schreibweise erinnert mich an "Regular Expressions", was ich hier im Form kennen lernen durfte

[RPP63]

das funktioniert auch innerhalb Excel

PHP-Code:

=TEXT(BD12;"JJJJ\/MM") 


Moin Wastl!
Ja, das geht. ;)
Aber warum um Himmels Willen sollte man ein Zeichen maskieren (durch den Backslash), wenn es durch die Anwendung NICHT fehlinterpretiert werden kann?
(NUR deshalb (engl. Datums-Trennzeichen ist der Slash) muss man in VBA diesen Umweg gehen)

?Format(Date, "yyyy/mm")
2018.03

?Format(Date, "yyyy\/mm")
2018/03

	A	B
1	02.05.2018	2018/05

Zelle	Format	Wert
A1	TT.MM.JJJJ	02.05.2018

Zelle	Formel
B1	=TEXT(A1;"JJJJ/MM")

Gruß Ralf

[schauan]

Hallo Ralf,

Du hattest ja zwischendrin auch mal nach der Laufzeit gefragt. Ich habe hier mal nur für den ersten Teil Deine Variante mit der Schleife, dann eine mit temporärer Formeleintragung und anschließend Ersatz durch Werte und als drittes eine Variante mit Arrays.

Im Code nutze ich auch vom ListObject den DataBodyRange. Damit's was einzutragen gibt habe ich in Spalte H mal ein paar Namen eingetragen und auf dem Blatt Listen3 noch eine Tabelle / Liste angelegt (heißt bei mir "Tabelle1") mit Namen und Typen.

Bei der Arrayvariante nehme ich übrigens nicht den kompletten Bereich, sondern nur die jeweiligen Spalten in  einzelne Arrays. Da kann man dann einfacher mit Match, Filter usw. und ohne Schleife arbeiten als in einem 2D-Array
 
Hier nun der Code.

Code:

Option Explicit
' ---------------------------------------------------------
'Deklaration der API-Funktion
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Sub test1()
'141 Sekunden
Dim loStartTime As Long, i, Kunde$, Ergebnis, KundenTyp$
loStartTime = GetTickCount
With Tabelle1.ListObjects("tabelle24").DataBodyRange
'Ermittle Kunde und Kundentyp
For i = 1 To .Rows.Count
 Kunde = .Range("H" & i)
 Set Ergebnis = Sheets("Listen3").Columns(1).Find(what:=Kunde, LookAt:=xlWhole)
 If Ergebnis Is Nothing Then
    KundenTyp = "n.d."
 Else
    KundenTyp = Sheets("Listen3").Range("B" & Ergebnis.Row)    'Blatt Listen3
 End If
 .Range("AS" & i) = KundenTyp
Next
End With
MsgBox "Laufzeit " & _
 (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
   vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

Sub test2()
'2-3 Sekunden
Dim loStartTime As Long, i%
loStartTime = GetTickCount
With Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns("AS")
 .FormulaR1C1 = _
        "=IF(COUNTIF(Tabelle1[[#All],[Kunde]],[@[Bestellt von]])=0,""n.d."",INDEX(Tabelle1[[#All],[Typ]],MATCH([@[Bestellt von]],Tabelle1[[#All],[Kunde]],0),1))"
 .Value = .Value
End With
MsgBox "Laufzeit " & _
 (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
   vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

Sub test3()
'0,4 Sekunden
Dim loStartTime As Long, i, Kunde$, Ergebnis, KundenTyp$, arrKunde, arrTyp
loStartTime = GetTickCount
arrKunde = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(8)
arrTyp = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(45)
'Ermittle Kunde und Kundentyp
For i = 1 To UBound(arrKunde)
 Kunde = arrKunde(i, 1)
 Ergebnis = Application.Match(Kunde, Tabelle2.ListObjects("Tabelle1").DataBodyRange.Columns(1), 0)
'  Set Ergebnis = Columns(1).Find(what:=Kunde, LookAt:=xlWhole)
 If IsError(Ergebnis) Then
    KundenTyp = "n.d."
 Else
    KundenTyp = Tabelle2.ListObjects("Tabelle1").DataBodyRange.Columns(2).Cells(Ergebnis, 1)   'Blatt Listen3
 End If
 arrTyp(i, 1) = KundenTyp
 'Range("AS" & i) = KundenTyp
Next
Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(45) = arrTyp
MsgBox "Laufzeit " & _
 (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
   vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

[Rabe]

Hi,

danke für eure Beiträge.

Da ich gerade mit Influenza daheim liege, komme ich an die Original-Datei nicht heran.
Aber die Beispieldatei entspricht schon dem Original, nur daß ich die Spalte H und Liste3 leergelassen habe. Da bei der Formel für Spalte AS ja dann "n.d." eingefügt wird, ging ich davon aus, daß das (eigentlich) für den Makrolauf irrelevant ist, wenn in H und Liste3 nichts drin steht. Die Wunschergebnisse stehen in den Spalten AS bis AW in den Zeilen 3 bis 14410.

So, jetzt habe ich es getestet:
Test1 benötigt bei mir 123,8 s, es wird aber AS für Zeilen, in denen in H nichts drin steht, leer gelassen.
Test2 benötigt bei mir 6,25 s.
Test3 benötigt bei mir 7,516 s.

Mit der Beispieldatei und 2 verschiedenen Kundennamen in Spalte H von Zeile 14411 bis unten und zwei Typen.

[schauan]

Hallo Ralf,

man sieht auf jeden Fall, dass eine Schleife bei größeren Datenmengen kein probates Mittel ist
Ob man dann von Fall zu Fall mit dem temporären Einsatz von Formeln arbeitet oder gleich mit Arrays, muss man schauen.

Das mit dem "Soll: 3 Sekunden" in den Meldungen ist hier übrigens Quatsch - das kommt noch von dem Beispielcode auf meiner Seite. Bin ja schon froh, dass ich nicht das ganze Beispielmas Makro von dort gepostet habe

[Rabe]

Hi André,

jetzt komme ich nur noch nicht drauf, wie ich diese Schleifen-Zeilen auf das Array-Format oder die Formeln für Dein Test2 umstellen kann:

         'Datum geliefert: Jahr/Monat eintragen 
         If IsDate(.Range("T" & i)) Then .Range("AT" & i) = Format(.Range("T" & i), "yyyy") & "/" & Format(.Range("T" & i), "mm") Else .Range("AT" & i) = "n.d."
         'Datum geliefert: Jahr/Quartal eintragen 
         If IsDate(.Range("T" & i)) Then .Range("AU" & i) = Format(.Range("T" & i), "yyyy") & "/" & (-Int(-Month(.Range("T" & i)) / 3)) Else .Range("AU" & i) = "n.d."

         'Suchhilfe 
         .Range("AV" & i) = .Range("I" & i) & " " & .Range("J" & i) & " " & .Range("L" & i)

         'Suchhilfe Seriennummer 
         If year(.Cells(i, 7)) < 2001 Then
            .Range("AW" & i) = "'" & Format(.Range("F" & i), "000") & Format(.Range("G" & i), "mm") & Right(.Range("A" & i), 1)
         Else
            .Range("AW" & i) = "'" & Format(.Range("F" & i), "0000") & Format(.Range("G" & i), "mm") & Format(.Range("G" & i), "yy")

So geht es für die beiden geliefert-Datumsspalten, für die zwei Suchhilfen habe ich noch keine Lösung

Code:

Sub test3()
   '0,4 Sekunden => 7,5 Sekunden
   Dim loStartTime As Long, i, Kunde$, Ergebnis, KundenTyp$, arrKunde, arrTyp
   Dim arrGeliefert, arrGeliefertQuartal
   Dim Lieferdatum As String, Suchstring As String
  
   loStartTime = GetTickCount
   arrKunde = Tabelle1.ListObjects("Tabelle24").DataBodyRange.Columns(8)
   arrTyp = Tabelle1.ListObjects("Tabelle24").DataBodyRange.Columns(45)
  
   arrGeliefert = Tabelle1.ListObjects("Tabelle24").DataBodyRange.Columns(20)
   arrGeliefertQuartal = Tabelle1.ListObjects("Tabelle24").DataBodyRange.Columns(20)
  
   'Ermittle Kunde und Kundentyp
   For i = 1 To UBound(arrKunde)
      Kunde = arrKunde(i, 1)
      Ergebnis = Application.Match(Kunde, Tabelle2.ListObjects("Tabelle1").DataBodyRange.Columns(1), 0)
      '  Set Ergebnis = Columns(1).Find(what:=Kunde, LookAt:=xlWhole)
      If IsError(Ergebnis) Then
         KundenTyp = "n.d."
      Else
         KundenTyp = Tabelle2.ListObjects("Tabelle1").DataBodyRange.Columns(2).Cells(Ergebnis, 1)   'Blatt Listen3
      End If
      arrTyp(i, 1) = KundenTyp
      'Range("AS" & i) = KundenTyp
   Next
   Tabelle1.ListObjects("Tabelle24").DataBodyRange.Columns(45) = arrTyp
  
   'Geliefert Monat: Jahr/Monat eintragen
   'If IsDate(.Range("T" & i)) Then .Range("AT" & i) = Format(.Range("T" & i), "yyyy") & "/" & Format(.Range("T" & i), "mm") Else .Range("AT" & i) = "n.d."
   'Geliefert Quartal: Jahr/Quartal eintragen
   'If IsDate(.Range("T" & i)) Then .Range("AU" & i) = Format(.Range("T" & i), "yyyy") & "/" & (-Int(-Month(.Range("T" & i)) / 3)) Else .Range("AU" & i) = "n.d."
   For i = 1 To UBound(arrGeliefert)
      If Not IsDate(arrGeliefert(i, 1)) Then
         arrGeliefert(i, 1) = "n.d."
         arrGeliefertQuartal(i, 1) = "n.d."
      Else
         arrGeliefert(i, 1) = Format(arrGeliefert(i, 1), "yyyy") & "/" & Format(arrGeliefert(i, 1), "mm")
         arrGeliefertQuartal(i, 1) = Format(arrGeliefertQuartal(i, 1), "yyyy") & "/" & (-Int(-Month(arrGeliefertQuartal(i, 1)) / 3))
      End If
   Next
   Tabelle1.ListObjects("Tabelle24").DataBodyRange.Columns(46) = arrGeliefert
   Tabelle1.ListObjects("Tabelle24").DataBodyRange.Columns(47) = arrGeliefertQuartal
  
   'Suchhilfe
   '.Range("AV" & i) = .Range("I" & i) & " " & .Range("J" & i) & " " & .Range("L" & i)
   'Suchhilfe Seriennummer
   'If year(.Cells(i, 7)) < 2001 Then
   '.Range("AW" & i) = "'" & Format(.Range("F" & i), "000") & Format(.Range("G" & i), "mm") & Right(.Range("A" & i), 1)
   'Else
   '.Range("AW" & i) = "'" & Format(.Range("F" & i), "0000") & Format(.Range("G" & i), "mm") & Format(.Range("G" & i), "yy")
  
   MsgBox "Laufzeit " & _
       (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
       vbInformation, "Laufzeit des Makros"
End Sub

[schauan]

Hallo Ralf,

hier habe ich mal die beiden Aufgaben zusammengefasst mit der Array-Variante. Habe jetzt aber erst mal nicht geschaut, ob die Ergebnisse plausibel sind.

Code:

Sub test4()
'6,8 SeSendern
Dim loStartTime As Long, i, Sender$, Ergebnis, SendernTyp$
Dim arrSend, arrLief_JM, arrLief_Q
Dim arrAL, arrAV, arrAW
loStartTime = GetTickCount
'fuer ersten Teil
arrSend = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(20) 'T
arrLief_JM = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(46) 'AT
arrLief_Q = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(47) 'AU
'fuer zweiten Teil
arrAL = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns("A:L") 'A:L
arrAV = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(48) 'AV
arrAW = Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(49) 'AW

'Ermittle Sender und Senderntyp
For i = 1 To UBound(arrSend)
  Sender = arrSend(i, 1)
  'Datum geliefert:
  If IsDate(arrSend(i, 1)) Then
    'Jahr/Monat eintragen
    arrLief_JM(i, 1) = Format(arrSend(i, 1), "yyyy") & "/" & Format(arrSend(i, 1), "mm")
    'Jahr/Quartal eintragen
    arrLief_Q(i, 1) = Format(arrSend(i, 1), "yyyy") & "/" & (-Int(-Month(arrSend(i, 1)) / 3))
  Else
    arrLief_JM(i, 1) = "n.d."
    arrLief_Q(i, 1) = "n.d."
  End If

  'Suchhilfe
  arrAV(i, 1) = arrAL(i, 9) & " " & arrAL(i, 10) & " " & arrAL(i, 12)
  'Suchhilfe Seriennummer
  If year(arrAL(i, 7)) < 2001 Then
     arrAW(i, 1) = "'" & Format(arrAL(i, 6), "000") & Format(arrAL(i, 7), "mm") & Right(arrAL(i, 1), 1)
  Else
     arrAW(i, 1) = "'" & Format(arrAL(i, 6), "000") & Format(arrAL(i, 7), "mm") & Format(arrAL(i, 7), , "yy")
  End If
Next
Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(46) = arrLief_JM
Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(47) = arrLief_Q
Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(48) = arrAV
Tabelle1.ListObjects("tabelle24").DataBodyRange.Columns(49) = arrAW
MsgBox "Laufzeit " & _
  (GetTickCount - loStartTime) / 1000 & " SeSendern.", _
    vbInformation, " SeSendern"
End Sub