beschleunigen

Hallo
könnte Hilfe gebrauchen
Habe mir heute aus dem super Forum folgenden Code zusammengebastelt
Dim rng As Range
Dim c As Range
Set rng = Range(Cells(1, 5), Cells(5000, 5)) 'Bereich aendern, hier E2 bis E5000
For Each c In rng
If c = "CPD WEMPF" Then c.Offset(0, 1).FormulaR1C1 = "=VLOOKUP(RC4,'Mandant 784 Bereich Simmern'!R2C1:R25965C4,4,0)"
If c = "aus SAP" Then c.Offset(0, 1).FindNext
If c > 0 And c If c = "CPD WEMPF" Then c.Offset(0, 2).FormulaR1C1 = "=VLOOKUP(RC4,'Mandant 784 Bereich Simmern'!R2C1:R25965C4,3,0)"
If c = "aus SAP" Then c.Offset(0, 2).FindNext
If c > 0 And c If c = "CPD WEMPF" Then c.Offset(0, 3).FormulaR1C1 = "=VLOOKUP(RC4,'Mandant 784 Bereich Simmern'!R2C1:R25965C4,2,0)"
If c = "aus SAP" Then c.Offset(0, 3).FindNext
If c > 0 And c Next c
Meine Frage ist: geht das auch schneller?
Zur Info:
1) Cells(5000 ; wie viele Zeilen die Tabelle hat, ist immer neu aber nie 5000
2) VLOOKUP ; kann man auch nur die Werte in die Zellen eintragen lassen nicht die Formel?
3) > 0 And c 4) Die Tabelle Mandant 784*** ist wirklich so groß
Leider habe ich von VBA keine Ahnung
Dank im Voraus
Gruß Joachim

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub joachim() Dim rng As Range Dim lngCalc As Long On Error GoTo ErrExit With Application .ScreenUpdating = False .EnableEvents = False lngCalc = .Calculation .Calculation = xlCalculationManual .DisplayAlerts = False End With With ActiveSheet For Each rng In .Range(.Cells(1, 5), .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row, 5)) 'Bereich aendern, hier E2 bis Exxxx If rng = "CPD WEMPF" Or IsNumeric(rng) Then rng.Offset(0, 1) = Evaluate("VLOOKUP($D1,'Mandant 784 Bereich Simmern'!$A$2:$D$25965,4,0)") rng.Offset(0, 2) = Evaluate("VLOOKUP($D1,'Mandant 784 Bereich Simmern'!$A$2:$D$25965,3,0)") rng.Offset(0, 3) = Evaluate("VLOOKUP($D1,'Mandant 784 Bereich Simmern'!$A$2:$D$25965,2,0)") End If Next End With ErrExit: With Err If .Number <> 0 Then MsgBox "Fehler in Prozedur:" & vbTab & "'joachim'" & vbLf & String(60, "_") & _ vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _ "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _ .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _ "VBA - Fehler in Modul - Modul1" .Clear End If End With On Error GoTo 0 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = lngCalc .DisplayAlerts = True End With End Sub

Hallo Joachim,

Sub joachim()
  Dim rng As Range
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  With ActiveSheet
    For Each rng In .Range(.Cells(1, 5), .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row, 5)) 'Bereich aendern, hier E2 bis Exxxx
      If rng = "CPD WEMPF" Or IsNumeric(rng) Then
        rng.Offset(0, 1) = Evaluate("VLOOKUP(" & rng.Offset(0, -1).Address & ",'Mandant 784 Bereich Simmern'!$A$2:$D$25965,4,0)")
        rng.Offset(0, 2) = Evaluate("VLOOKUP(" & rng.Offset(0, -1).Address & ",'Mandant 784 Bereich Simmern'!$A$2:$D$25965,3,0)")
        rng.Offset(0, 3) = Evaluate("VLOOKUP(" & rng.Offset(0, -1).Address & ",'Mandant 784 Bereich Simmern'!$A$2:$D$25965,2,0)")
      End If
    Next
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'joachim'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread