Clever-Excel-Forum

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

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.

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?

Hallo Michael,

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

Zitat: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

(05.07.2017, 14:12)Rabe schrieb: [ -> ]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

Hi,

(05.07.2017, 17:43)cysu11 schrieb: [ -> ]Danke trotzdem, habe aber inzwischen die Lösung von Michael eingebaut und bin sehr glücklich damit!

ja, der Code ist deutlich effektiver!

cysu11

Der Steuerfuzzi

Rabe

cysu11

cysu11

Rabe