Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1556to1560
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Datenübertragung/ Makro optimieren

Datenübertragung/ Makro optimieren
04.05.2017 09:23:44
Kevin
Hallo liebe Forummitglieder,
ein kleines Attentat, zumindest in meinen Augen.^^
Ich habe ein Makro, welches mir Daten von einzelnen Detailansichten in eine Gesamtübersicht kopiert. Die Daten werden Zelle für Zelle von einer "Spaltenanordnung" in eine "Zeilenanordnung" in der Gesamtübersicht kopiert.
Mein Problem: Ich habe knapp 60 Detailansichten und das Kopieren dauert extrem lange. Die Idee ist anstatt die Daten Zelle für Zelle zu kopieren dann Bereich für Bereich zu kopieren.
Die Bereiche
Detailansicht von: C4:C31
Übersicht: C5:AD5
Kann mir da einer weiterhelfen? Das ist hier zumindest das Makro.
Anbei auch eine Beispieldatei. Das Makro befindet sich im Modul 4. (mit so wenigen Daten wie im Beispiel läuft es noch gut.^^)
https://www.herber.de/bbs/user/113297.xlsm
Vielen dank im Voraus!
Gruß
Kevin
Sub Overview_Update()
Application.ScreenUpdating = False
Application.EnableEvents = False
Worksheets("Machining overview").Rows(1).Hidden = False
LastRow = Worksheets("Machining overview").Cells(Rows.Count, 1).End(xlUp).Row                _
_
'Letzte gefüllte Zeile in Tabelle
FirstCol = Worksheets("Machining overview").Rows(1).Find("*", lookat:=xlWhole, LookIn:= _
xlValues).Column 'Beginn der Einträge in Zeile 1
NumberCol = WorksheetFunction.CountA(Worksheets("Machining overview").Rows(1))               _
_
'Anzahl Einträge in Zeile 1
Worksheets("Machining overview").Rows(1).Hidden = True
'Kopiere Werte aus Detailblatt in Overview
'Spalte B Link einfügen
Zeile = 5      'Startzeile der Tabelle
SZeile = Zeile - 1
For i = Zeile To LastRow
Worksheets("Machining overview").Rows(i).ClearContents
Next i
For i = 1 To Sheets.Count
If Sheets(i).Name = "Machining overview" Then  'Machining overview ist anders  _
geschrieben
For j = i + 1 To Sheets.Count
Range("A" & Zeile) = Zeile - SZeile
Range("B" & Zeile) = Worksheets(j).Name
Range("B" & Zeile).Hyperlinks.Add Anchor:=Range("B" & Zeile), Address:="",  _
SubAddress:="'" & Worksheets(j).Name & "'!A1", TextToDisplay:=Worksheets(j).Name
For k = 1 To NumberCol
Worksheets(j).Range(Worksheets("Machining overview").Cells(1, k + FirstCol - _
_
1)).Copy       'Suche Zelle aus Zeile 1 im neuen Blatt
Worksheets("Machining overview").Cells(Zeile, k + FirstCol - 1). _
PasteSpecial Paste:=xlPasteValues  'Füge Werte ein
Next k
Zeile = Zeile + 1
Next j
End If
Next i
' Sortiere nach Spalte G "Processing method" aufsteigend, wenn Spalte geändert anpassen "Range(" _
_
L5")"
ActiveWorkbook.Worksheets("Machining overview").ListObjects("Tabelle1").Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("Machining overview").ListObjects("Tabelle1").Sort. _
SortFields.Add Key:=Range("L5"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Machining overview").ListObjects("Tabelle1"). _
Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Datenübertragung/ Makro optimieren
04.05.2017 09:43:24
Kevin
Servus Bernd,
entschuldige bitte.
Habe mich bei den mehrfahren upload sehr gewundert. Sonst kommt ja nach dem absenden eines Beitrags der geschriebene Text in dicker Schrift als Bestätigung. Dieser kam aber nicht und dann habe ich mehrmals auf absenden gedrückt.
Ich hatte deine Antwort erst gesehen, als ich den anderen Beitrag schon raus hatte. Simultan war ich noch an Excel deswegen die zeitverzögerte Antwort beim anderen Beitrag. Entschuldigung!
Liebe Grüße
Kevin
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige