Code optimieren!

[cysu11]

Hallo zusammen,


habe mir aus dem Internet folgenden Code gesucht und an meine Bedürfnisse angepasst!
Er ist allerdings extrem langsam :(

Kann jemand diesen ein wenig Speed verpassen!? :)

Code:

Sub ZusammenFuehrenUndAusgeben()
Dim a As Variant
Dim letzte As Long
Dim i As Long
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Set wksQ = Worksheets("PD")
Set wksZ = Worksheets("Lieferungen")
letzte = wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Row
   For i = 7 To letzte
     a = Application.Match(wksZ.Cells(i, 1), wksQ.Columns(1), 0)
       If IsNumeric(a) Then
         wksZ.Cells(i, 19).Value = wksQ.Cells(a, 1).Value
         wksZ.Cells(i, 20).Value = wksQ.Cells(a, 2).Value
         wksZ.Cells(i, 21).Value = wksQ.Cells(a, 3).Value
         wksZ.Cells(i, 22).Value = wksQ.Cells(a, 4).Value
         wksZ.Cells(i, 23).Value = wksQ.Cells(a, 5).Value
         wksZ.Cells(i, 24).Value = wksQ.Cells(a, 6).Value
         wksZ.Cells(i, 25).Value = wksQ.Cells(a, 7).Value
         wksZ.Cells(i, 26).Value = wksQ.Cells(a, 8).Value
         wksZ.Cells(i, 27).Value = wksQ.Cells(a, 9).Value
         wksZ.Cells(i, 28).Value = wksQ.Cells(a, 10).Value
         wksZ.Cells(i, 29).Value = wksQ.Cells(a, 11).Value
         wksZ.Cells(i, 30).Value = wksQ.Cells(a, 12).Value
         wksZ.Cells(i, 31).Value = wksQ.Cells(a, 13).Value
         wksZ.Cells(i, 32).Value = wksQ.Cells(a, 14).Value
         wksZ.Cells(i, 33).Value = wksQ.Cells(a, 15).Value
         wksZ.Cells(i, 34).Value = wksQ.Cells(a, 16).Value
         wksZ.Cells(i, 35).Value = wksQ.Cells(a, 17).Value
         wksZ.Cells(i, 36).Value = wksQ.Cells(a, 18).Value
         wksZ.Cells(i, 37).Value = wksQ.Cells(a, 19).Value
         wksZ.Cells(i, 38).Value = wksQ.Cells(a, 20).Value
         wksZ.Cells(i, 39).Value = wksQ.Cells(a, 21).Value
         wksZ.Cells(i, 40).Value = wksQ.Cells(a, 22).Value
         wksZ.Cells(i, 41).Value = wksQ.Cells(a, 23).Value
         wksZ.Cells(i, 42).Value = wksQ.Cells(a, 24).Value
         wksZ.Cells(i, 43).Value = wksQ.Cells(a, 25).Value
         wksZ.Cells(i, 44).Value = wksQ.Cells(a, 26).Value
         wksZ.Cells(i, 45).Value = wksQ.Cells(a, 27).Value
         wksZ.Cells(i, 46).Value = wksQ.Cells(a, 28).Value
         wksZ.Cells(i, 47).Value = wksQ.Cells(a, 29).Value
         wksZ.Cells(i, 48).Value = wksQ.Cells(a, 30).Value
         wksZ.Cells(i, 49).Value = wksQ.Cells(a, 31).Value
         wksZ.Cells(i, 50).Value = wksQ.Cells(a, 32).Value
         wksZ.Cells(i, 51).Value = wksQ.Cells(a, 33).Value
         
       Else
         MsgBox "nicht vorhanden"
       End If
   Next
Set wksQ = Nothing
Set wksZ = Nothing
End Sub

Vielen Dank
VG
Alexandra

[Der Steuerfuzzi]

Hallo,

mal auf die Schnelle die Spalten zusammengeführt. Schau mal, ob das schon schneller geht:

Code:

Sub ZusammenFuehrenUndAusgeben()
Dim a As Variant
Dim letzte As Long
Dim i As Long
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Set wksQ = Worksheets("PD")
Set wksZ = Worksheets("Lieferungen")
letzte = wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Row
   For i = 7 To letzte
     a = Application.Match(wksZ.Cells(i, 1), wksQ.Columns(1), 0)
       If IsNumeric(a) Then
         wksZ.Cells(i, 19).Resize(1, 33).Value = wksQ.Cells(a, 1).Resize(1, 33).Value
       Else
         MsgBox "nicht vorhanden"
       End If
   Next
Set wksQ = Nothing
Set wksZ = Nothing
End Sub

Müsste es nicht heißen: letzte = wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Row + 1
Sonst überschreibt er doch die letzte Zeile?

Wenn das noch nicht schnell genug ist, könnte man das ganze über ein Array lösen.

[Rabe]

Hi,
geht es so schneller?

Sub ZusammenFuehrenUndAusgeben()
   Dim a As Variant
   Dim letzte As Long
   Dim i As Long, j As Long
   Dim wksQ As Worksheet
   Dim wksZ As Worksheet
   Set wksQ = Worksheets("PD")
   Set wksZ = Worksheets("Lieferungen")
   letzte = wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Row
   For i = 7 To letzte
      a = Application.Match(wksZ.Cells(i, 1), wksQ.Columns(1), 0)
      If IsNumeric(a) Then
         For j = 1 To 33
            wksZ.Cells(i, j + 18).Value = wksQ.Cells(a, j).Value
         Next j
      Else
         MsgBox "nicht vorhanden"
      End If
   Next
   Set wksQ = Nothing
   Set wksZ = Nothing
End Sub

und vor allem, macht er das gleiche?

[cysu11]

Hallo Michael,


sehr gut, es geht deutlich schneller! Vielen Dank dafür!

Müsste es nicht heißen: letzte = wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Row + 1

Sonst überschreibt er doch die letzte Zeile?

Nein es soll nur der Bereiche ermittelt werden, die Daten werden rechts an der Tabelle drangehängt! :)
Vielen Dank
VG
Alexandra

[cysu11]

Hi,
geht es so schneller?

Sub ZusammenFuehrenUndAusgeben()

   Dim a As Variant

   Dim letzte As Long

   Dim i As Long, j As Long

   Dim wksQ As Worksheet

   Dim wksZ As Worksheet

   Set wksQ = Worksheets("PD")

   Set wksZ = Worksheets("Lieferungen")

   letzte = wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Row

   For i = 7 To letzte

      a = Application.Match(wksZ.Cells(i, 1), wksQ.Columns(1), 0)

      If IsNumeric(a) Then

         For j = 1 To 33

            wksZ.Cells(i, j + 18).Value = wksQ.Cells(a, j).Value

         Next j

      Else

         MsgBox "nicht vorhanden"

      End If

   Next

   Set wksQ = Nothing

   Set wksZ = Nothing

End Sub

und vor allem, macht er das gleiche?

Der macht anscheinend das Gleiche, nur braucht er genau so lang wie mein ursprünglicher! :)

Danke trotzdem, habe aber inzwischen die Lösung von Michael eingebaut und bin sehr glücklich damit!

Vielen Dank
VG
Alexandra

[Rabe]

Hi,

Danke trotzdem, habe aber inzwischen die Lösung von Michael eingebaut und bin sehr glücklich damit!

ja, der Code ist deutlich effektiver!