Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Vervielfältigung von Tabellenzeilen, beschleunigung Makro
zurück: Textfeld mit zelle verknüpfen weiter: Nr. + 1 hochzählen nach berücksichtigung aus anderer Tabelle Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Feedback Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
sammy-2x
Im Profil kannst Du frei den Rang ändern


Verfasst am:
16. Jul 2010, 16:19
Rufname:

Vervielfältigung von Tabellenzeilen, beschleunigung Makro - Vervielfältigung von Tabellenzeilen, beschleunigung Makro

Nach oben
       Version: Office 2007

Hallo,

vielleicht kann mir jemand bei der Beschleunigung des Makros helfen oder hat einen besseren Vorschlag.
Je Tabellenzeile sollen einige Zellen bedingt oft vervielfältigt/dupliziert im Tabellenblatt Abruf_Truck untereinander eingefügt werden. Wie oft die Vervielfachung erfolgen soll bestimmt die jeweilige Zelle der Spalte L.
Der Code funktioniert einwandfrei, nur dauert mir die Abarbeitung zu lange. Bei vielen Daten bzw. Kopiervorgängen bis zu 5 Minuten.

Vielen Dank im Voraus.


Code:

Sub Abruf_aufbereiten()
Dim rngCell As Range, lngRowCounter As Long, lngRowCount As Long
Dim objNewSheet As Worksheet, objOldSheet As Worksheet
Set objOldSheet = ThisWorkbook.Worksheets("Abruf")
Set objNewSheet = ThisWorkbook.Worksheets("Abruf_Truck")

Application.ScreenUpdating = False

objNewSheet.Range("B1:D91").ClearContents
For Each rngCell In objOldSheet.Range(objOldSheet.[A1], objOldSheet.[A61])
'Wenn in Spalte "1" angeben ist, wird die Schleife ausgeführt
    If rngCell.Offset(0, 14) = 1 Then
    For lngRowCount = 1 To rngCell.Offset(0, 11)
        lngRowCounter = lngRowCounter + 1
        objNewSheet.Cells(lngRowCounter, 2) = rngCell
        objNewSheet.Cells(lngRowCounter, 3) = rngCell.Offset(0, 1)
        objNewSheet.Cells(lngRowCounter, 4) = rngCell.Offset(0, 15)
    Next
    End If
Next

Application.ScreenUpdating = True

End Sub
Phelan XLPH
Fortgeschritten


Verfasst am:
16. Jul 2010, 16:29
Rufname: Phelan


AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr - AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr

Nach oben
       Version: Office 2007

Hallo Sammy,

wenn die Bedingung rngCell.Offset(0, 14) = 1 mehr als 1mal
erfüllt ist dann werden die werte im NewSheet immer überschrieben.
Kann die Bedingung mehr als 1mal erfüllt sein?

_________________
Was vorstellbar ist, ist auch machbar. - Albert Einstein
Phelan XLPH
Fortgeschritten


Verfasst am:
16. Jul 2010, 16:38
Rufname: Phelan

AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr - AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr

Nach oben
       Version: Office 2007

versuchs hiermit, ist ungetestet:

Code:
Sub Abruf_aufbereiten()
Dim rngCell As Range, lngRowCounter As Long, lngRowCount As Long
Dim objNewSheet As Worksheet, objOldSheet As Worksheet
Dim lngLZ As Long, intCalc As Integer
Set objOldSheet = ThisWorkbook.Worksheets("Abruf")
Set objNewSheet = ThisWorkbook.Worksheets("Abruf_Truck")

On Error GoTo ENDE

intCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

objNewSheet.Range("B1:D91").ClearContents
For Each rngCell In objOldSheet.Range(objOldSheet.[A1], objOldSheet.[A61])
'Wenn in Spalte "1" angeben ist, wird die Schleife ausgeführt
    If rngCell.Offset(0, 14) = 1 Then
    lngLZ = objNewSheet.Cells(Rows.Count, 2).End(xlUp).Row
    With rngCell.Offset(0, 11)
        objNewSheet.Cells(lngLZ + 1, 2).Resize(.Value) = rngCell
        objNewSheet.Cells(lngLZ + 1, 3).Resize(.Value) = rngCell.Offset(0, 1)
        objNewSheet.Cells(lngLZ + 1, 4).Resize(.Value) = rngCell.Offset(0, 15)
    End With
    End If
Next

ENDE:
Application.EnableEvents = True
Application.Calculation = intCalc
Application.ScreenUpdating = True
If Err Then Err.Description , , "Fehler: " & Err

End Sub

_________________
Was vorstellbar ist, ist auch machbar. - Albert Einstein
sammy-2x
Im Profil kannst Du frei den Rang ändern


Verfasst am:
17. Jul 2010, 09:16
Rufname:

AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr - AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr

Nach oben
       Version: Office 2007

Hallo Glückritter,

Danke für deine Antworten

Bedingung rngCell.Offset(0, 14) = 1
Der Zellenwert ist entweder 1 oder 0. Beim Wert 1 soll die Schleife durchlaufen werden. Wenn der Zellenwert 0 ist dann soll die nächste Tabellenzeile geprüft werden...

Problem mit deinem Vorschlag:
In das zweite Tabellenblatt "Abruf_Truck" werden keine Daten übernommen/geschrieben.

Zudem macht mir die letzte Makrozeile Probleme
If Err Then Err.Description , , "Fehler: " & Err
Fehlermeldung: Unzulässige Verwendung einer Eigenschaft
Phelan XLPH
Fortgeschritten


Verfasst am:
17. Jul 2010, 09:20
Rufname: Phelan

AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr - AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr

Nach oben
       Version: Office 2007

Hallo Sammy,

kannst du die Datei hochladen?

_________________
Was vorstellbar ist, ist auch machbar. - Albert Einstein
Gast



Verfasst am:
17. Jul 2010, 11:57
Rufname:


AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr - AW: Vervielfältigung von Tabellenzeilen, beschleunigung Makr

Nach oben
       Version: Office 2007

Bin noch nicht freigeschalten um Dateien hochladen zu können.

Hab jetzt das alte Makro um die zusätzlichen Application Zeilen erweitert und jetzt läuft es extrem schnell.

Vielen Dank für deine Hilfe.


Code:
Sub Abruf_aufbereiten()
Dim rngCell As Range, lngRowCounter As Long, lngRowCount As Long
Dim objNewSheet As Worksheet, objOldSheet As Worksheet
Set objOldSheet = ThisWorkbook.Worksheets("Abruf")
Set objNewSheet = ThisWorkbook.Worksheets("Abruf_Truck")

On Error GoTo ENDE

intCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False


objNewSheet.Range("B1:D91").ClearContents
For Each rngCell In objOldSheet.Range(objOldSheet.[A1], objOldSheet.[A61])
'Wenn in Spalte "1" angeben ist, wird die schleife ausgeführt
    If rngCell.Offset(0, 14) = 1 Then
    For lngRowCount = 1 To rngCell.Offset(0, 11)
        lngRowCounter = lngRowCounter + 1
        objNewSheet.Cells(lngRowCounter, 2) = rngCell
        objNewSheet.Cells(lngRowCounter, 3) = rngCell.Offset(0, 1)
        objNewSheet.Cells(lngRowCounter, 4) = rngCell.Offset(0, 15)
    Next
    End If
Next


ENDE:
Application.EnableEvents = True
Application.Calculation = intCalc
Application.ScreenUpdating = True

End Sub
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Tabellenzeilen automatisch füllen 4 xxsteffenxx 379 18. Dez 2007, 17:37
xxsteffenxx Tabellenzeilen automatisch füllen
Keine neuen Beiträge Excel Formeln: Makro, in Tabelle in erster leeren Zeile springen 2 Helmut_S 1323 05. Dez 2007, 18:51
Gast Makro, in Tabelle in erster leeren Zeile springen
Keine neuen Beiträge Excel Formeln: Priorisierung über Makro aktive Zelle Zeile ausblenden 1 eusebius 1020 08. Nov 2007, 18:20
Melanie Breden Priorisierung über Makro aktive Zelle Zeile ausblenden
Keine neuen Beiträge Excel Formeln: aktiven Zellen bestimmet Werte aus Makro zuweisen 4 hoebener 1634 19. Okt 2007, 21:47
fridgenep aktiven Zellen bestimmet Werte aus Makro zuweisen
Keine neuen Beiträge Excel Formeln: Brauche Hilfe! Formel und/oder VBA (Makro) 2 ::Patrick:: 2927 01. Aug 2007, 10:42
Gast Brauche Hilfe! Formel und/oder VBA (Makro)
Keine neuen Beiträge Excel Formeln: Sicherheitsabfrage vor Makro schalten 4 Gismo2 1521 10. Jul 2007, 07:49
Gismo2 Sicherheitsabfrage vor Makro schalten
Keine neuen Beiträge Excel Formeln: Datenübernahme aus Verschiedenen Tabellen per Makro 15 Cassius 3187 25. Apr 2007, 09:35
Cassius Datenübernahme aus Verschiedenen Tabellen per Makro
Keine neuen Beiträge Excel Formeln: Excel Makro das die aktuelle Zeit in hh:mm:ss einfügt 1 Duuuuude 2146 19. Feb 2007, 11:04
ex*cel*pert Excel Makro das die aktuelle Zeit in hh:mm:ss einfügt
Keine neuen Beiträge Excel Formeln: Problem mit vervielfältigung von einer Formel 2 Scapegoat 379 08. Feb 2007, 19:14
ScapeGoat Problem mit vervielfältigung von einer Formel
Keine neuen Beiträge Excel Formeln: Excel: Verketten Wenn (Makro?) 11 Sarah1981 4108 08. Feb 2007, 10:59
Gast Excel: Verketten Wenn (Makro?)
Keine neuen Beiträge Excel Formeln: End up, Markieren, Löschen mit Makro 10 detlef42 1290 21. Nov 2006, 16:13
Detlef 42 End up, Markieren, Löschen mit Makro
Keine neuen Beiträge Excel Formeln: Bedingteformatierung mit WENN/DANN oder vielleicht ein Makro 6 hiobsplimp 4064 15. Nov 2006, 17:17
12und20zig Bedingteformatierung mit WENN/DANN oder vielleicht ein Makro
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Microsoft Excel Tricks