VBA Prozedur zu groß
28.10.2015 15:59:44
Josef
ich hoffe ihr könnt mir bei meinem Problem helfen. Ich habe ca.100 Tabellenblätter die den selben VBA Code enthalten. Damit ich nicht jede Tabelle manuell anstoßen muss, habe ich alle Makros in ein Modul gepackt um es mit einem Commandbutton zu starten. Allerdings erhalte ich die Info, dass die "Prozedur zu groß" ist.
Es ist folgender Makro (ca. 100 mal) in meinem Modul hinterlegt:
(PS: was tut dieser Makro: Ich hole mir über eine URL (Zelle A1) die in jedem Tabellenblatt hinterlegt ist Daten aus einer Webabfrage und füge in jede Tabelle das Ergebnis ab Zelle "E1" ein.)
'Worksheets("tabelle2").Select
Columns("E:l").Select
Selection.ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Worksheets("Tabelle2").Range("$a$1").Value, _
Destination:=Range("$e$1"))
.Name = "abfrage.html"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
On Error Resume Next
.Refresh BackgroundQuery:=False
On Error Resume Next
Columns("I:I").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("I1").Select
Columns("I:I").Select
Selection.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("K1").Select
ActiveCell.FormulaR1C1 = "Menge"
Range("L1").Select
ActiveCell.FormulaR1C1 = "Preis"
Range("K1").Select
If Range("E1") 0 Then
Columns("E:H").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End If
End With
end sub'
Habt Ihr eine Lösung für mich?
MFG