Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1212to1216
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

XL File ohne Makro 5MB, mit VBA 35MB?

XL File ohne Makro 5MB, mit VBA 35MB?
Chris
Hallo,
durch ein Makro vergrößert sich einen Datei massiv und ich verstehe nicht warum.
Zunächst sortiere ich einige Spalten um:

Sub MarketAxess_SpaltenAnpassen()
Application.ScreenUpdating = False
Worksheets("Market Axess").Activate
Worksheets("Market Axess").Columns("K:K").Cut
Worksheets("Market Axess").Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("J:J").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("D:D").Select
Selection.ClearContents
Columns("H:H").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Cut
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Columns("M:M").Select
Selection.Cut
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
'Volumen mal 1000
Dim LastRowMarketAxess1  As Integer
LastRowMarketAxess1 = Worksheets("Market Axess").UsedRange.Rows.Count
For i = 1 To LastRowMarketAxess1
Worksheets("Market Axess").Range("E" & i).Value = Worksheets("Market Axess").Range("E" & _
_
i).Value * 1000
Next i
End Sub

Diese ausgeschnittenen Spalten werden doch nicht weiter gespeichert oder doch?
Dann folgt das eigentlich Makro, das aus drei Datensheets Zeileneinträge sucht. Die Schlüsselnamen werden für jedes Sheet in einer Namensliste eingegeben

Sub NurTabellenBlattNamen()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim wsname As String    'Name des Datenworksheets
Dim ws2name As String   'Name des Statistikworksheets
Dim nameRange As Range  'Liste der möglichen Firmennamen
Dim Namensvariante As Range 'Einzelne Firmennamenobjekte
'Mit Schleife die roten Worksheets finden
For Each ws In ThisWorkbook.Worksheets
If ws.Tab.ColorIndex = 3 Then
'Alte Daten löschen
ws.Range("A2:M65536").ClearContents
wsname = ws.Name
ws2name = wsname & "2"
'Liste definieren in der alle möglichen Firmennamenvarianten stehen
Set startnamerange = Worksheets(ws2name).Range("A80")
Set endnamerange = Worksheets(ws2name).Range("A90")
Set nameRange = Range(startnamerange, endnamerange)
For Each Namensvariante In nameRange
'Jetzt wurde ein Name aus der Firmennamenvariantenliste ausgewählt
'Anzahl der Zeilen in gelben Sheets finden die Daten enthalten
LastRowBBT = Worksheets("BBT").UsedRange.Rows.Count
LastRowMarketAxess = Worksheets("Market Axess").UsedRange.Rows.Count
LastRowTradeWeb = Worksheets("Trade Web").UsedRange.Rows.Count
'Letze Zeile im roten Datensheet finden
LastRowWSName = Worksheets(wsname).Range("B65536").End(xlUp).Row
'Jedes der drei gelben Datensheets durchlaufen
'1. BBT
For i = 2 To LastRowBBT
If Worksheets("BBT").Range("G" & i).Value = Namensvariante Then
Worksheets(wsname).Rows(LastRowWSName + 1).Value = Worksheets("BBT"). _
_
Rows(i).Value
LastRowWSName = Worksheets(wsname).Range("B65536").End(xlUp).Row
End If
Next i
'2. MarketAxess
For i = 2 To LastRowMarketAxess
If Worksheets("Market Axess").Range("G" & i).Value = Namensvariante  _
Then
Worksheets(wsname).Rows(LastRowWSName + 1).Value = Worksheets(" _
Market Axess").Rows(i).Value
LastRowWSName = Worksheets(wsname).Range("B65536").End(xlUp).Row
End If
Next i
'3. Trade Web
For i = 2 To LastRowTradeWeb
If Worksheets("Trade Web").Range("G" & i).Value = Namensvariante Then
Worksheets(wsname).Rows(LastRowWSName + 1).Value = Worksheets("Trade  _
_
Web").Rows(i).Value
LastRowWSName = Worksheets(wsname).Range("B65536").End(xlUp).Row
End If
Next i
Next Namensvariante
'Gesamten Datenblock eine Spalte nach rechts verschieben
Worksheets(wsname).Range("A2:L" & LastRowWSName).Cut
ActiveSheet.Paste Destination:=Worksheets(wsname).Range("B2:M" & LastRowWSName)
End If
Next ws
Call Datenkuerzeleinfuegen
End Sub


In den "gelben" Datensheets stehen einige Zeileneinträge (in einem Sheet etwa 20000), deswegen dauert es auch einige Zeit bis das Ergebnis kommt (15min), aber das ist nicht das Problem.
Zudem werden nur wenige der Zeilen in die entsprechenden roten Sheets kopiert, sodass nach dem Durchlauf des Makros nicht so viele Zellen mehr als vorher Daten enthalten - dennoch ist die Datei jetzt ca 7x so groß. Kann mir das bitte einer erklären?

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

Betreff
Benutzer
Anzeige
AW: XL File ohne Makro 5MB, mit VBA 35MB?
25.05.2011 11:37:48
Timo
Hallo Chris,
das erste Makro solltest Du schon mal "entschlacken", mit SELECT arbeitet man zu 99,9% nicht, da es a)langsam und b) im code unübersichtlich ist. :)
Sub MarketAxess_SpaltenAnpassen()
Dim LastRowMarketAxess1  As Integer
Application.ScreenUpdating = False
Worksheets("Market Axess").Activate
Columns("K:K").Cut
Columns("B:B").Insert Shift:=xlToRight
Columns("J:J").Cut
Columns("C:C").Insert Shift:=xlToRight
Columns("D:D").ClearContents
Columns("H:H").Cut
Columns("E:E").Insert Shift:=xlToRight
Columns("H:H").Cut
Columns("F:F").Insert Shift:=xlToRight
Columns("M:M").Cut
Columns("J:J").Insert Shift:=xlToRight
'Volumen mal 1000
LastRowMarketAxess1 = Worksheets("Market Axess").UsedRange.Rows.Count
For i = 1 To LastRowMarketAxess1
Range("E" & i).Value = Range("E" & i).Value * 1000
Next i
Application.ScreenUpdating = True
End Sub
Was allerdings die Datei so aufbläht konnte ich noch nicht herausfinden. Ich vermute aber, dass durch die vielen Kopiervorgänge irgendwo Spalten eingefügt werden, die nicht notwendig sind.
Gruß
Timo
Anzeige
AW: XL File ohne Makro 5MB, mit VBA 35MB?
25.05.2011 11:45:36
Timo
P.S.: Da steht im Code noch "Call Datenkuerzeleinfuegen" steht, kann die Ursache unter Umständen auch dort zu finden sein. Gruß Timo
AW: XL File ohne Makro 5MB, mit VBA 35MB?
26.05.2011 12:00:46
Dirk
Hallo!
Du kopierst eine komplette Spalte. Dadurch wird warscheinlich Deine UsedRange entsprechend erweitert, sodass Du dann alle Zellen als UsedRange vorhaelts.
Um das zu korrigieren solltest Du am ender dieser kopieraktionen folgendes machen:
1. Letzte benutzte Spalte suchen und alle nachfolgenden Spalten loeschen.
2. Letzte benutzte Zeile suchen und alle nachfolgenden Zeilen loeschen.
Danach sollte Deine Datei wieder etwas kleiner sein.
Du koenntest folgendes Makro dazu in ein Modul kopieren und aufrufen:
Sub FixUsedRange()
Dim r As String
Dim MyRangeR As String
Dim MyRangeC As String
MsgBox ActiveSheet.UsedRange.Address
'get last populated cell
r = Cells.Find("*", SearchOrder:=xlByRows, _
LookIn:=xlValues, SearchDirection:=xlPrevious).Address
MyRangeR = Range(Cells(Range(r).Row + 1, 1).Address, Cells(ActiveSheet.Rows.Count, 1).Address). _
Address
MyRangeC = Range(Cells(1, Range(r).Column + 1).Address, Cells(1, ActiveSheet.Columns.Count). _
Address).Address
ActiveSheet.Range(MyRangeR).EntireRow.Delete
ActiveSheet.Range(MyRangeC).EntireColumn.Delete
MsgBox ActiveSheet.UsedRange.Address
End Sub

Lass' hoeren, ob ok.
Gruss
Dirk aus Dubai
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige