VBA Prozedur zu groß

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: VBA Prozedur zu groß
von: Josef
Geschrieben am: 28.10.2015 15:59:44

Hallo Zusammen,
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

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Rudi Maintaire
Geschrieben am: 28.10.2015 16:12:17
Hallo,
teste mal.

Sub aaaa()
  Dim wks As Worksheet
  For Each wks In Worksheets
    With wks
      .Columns("E:l").ClearContents
      With .QueryTables.Add(Connection:= _
        "URL;" & wks.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").Replace What:=".", Replacement:=",", LookAt:=xlPart, _
          SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
          ReplaceFormat:=False
        .Columns("I:I").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") = "Menge"
        .Range("L1") = "Preis"
        If .Range("E1") <> 0 Then
          Columns("E:H").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        End If
      End With
    End With
  Next wks
End Sub

Gruß
Rudi

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Josef
Geschrieben am: 28.10.2015 16:30:56
Hallo Rudi,
danke, deine Lösung funktioniert (allerdings dauert das etwas lange). Ich denke wir können das etwas beschleunigen das Makro nur für die Tabellen durchläuft, wo in Zelle A1 auch wiklrich eine URL ist (URL wird über eine Formel ermittelt). Damit sollte das Makro schneller fertig sein, oder?

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Rudi Maintaire
Geschrieben am: 28.10.2015 16:35:35
Hallo,
Damit sollte das Makro schneller fertig sein, oder?
auf jeden Fall.
Gruß
Rudi

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Josef
Geschrieben am: 28.10.2015 16:38:26
Hi,
kannst du mir auch zeigen wir der Code dann aussehen muss?
Ich bin wirklich ein VBA-Neuling und ich habe mir alles durch viel Internetrecherche zusammengeschustert und natürlich durch deine Hilfe.

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Rudi Maintaire
Geschrieben am: 28.10.2015 16:44:38
was steht denn in A1 wenn es keine URL ist?
Motto:
for each wks in worksheets
with wks
if .Range("A1")<>"" then
'Code
end if
end with
next wks
Gruß
Rudi

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Josef
Geschrieben am: 29.10.2015 06:57:34
Hallo Rudi,
danke das du mir hilftst - konnte dir gestern leider nicht mehr antworten.
Für Tabelle 2 ist z. B. in Zelle A1 die Formel "=Tabelle1!D1",für Tabelle 3 ist die formel "=Tabelle1!D2", für Tabelle 3 "=Tabelle1!D3" u.s.w hinterlegt. Habe deinen Code heute ausgiebig testen können und musste leider feststellen, dass das nicht richtig funktioniert. Die Webabfragen funktionieren. Leider macht er das immernoch für alle Tabellenblätter, auch wenn A1 leer ist. Ausserdem habe ich nun das Problem, dass der Rest vom Makro nicht mehr funktioniert. Damit meine ich, dass in Spalte I "Punkt" nicht mehr durch "Komma" ersetzt wird und die Spalte nicht mehr von Text getrennt wird.
Hast du dafür auch eine Lösung?

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Rudi Maintaire
Geschrieben am: 29.10.2015 09:15:36
Hallo,
muss man eigentlich immer alles kleinschrittig vorkauen?

for each wks in worksheets
 with wks
  if .Range("A1")<>"" then
   'Code der ausgeführt werden soll wenn A1 nicht leer ist
  end if
   'Code der immer ausgeführt werden soll
 end with
next wks
Gruß
Rudi

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Josef
Geschrieben am: 29.10.2015 09:31:21
Hi,
hatte ich so ausprobiert hat aber nicht funktioniert.
Einfach mal die Datei anschauen. Vielleicht erkennt ihr dann mein Problem?

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Josef
Geschrieben am: 29.10.2015 09:13:07
Hallo Zusammen,
mein Makro scheint irgendwie nicht zu funktionieren. Ich habe nun mal eine Test Datei erstellt und hochgeladen.
https://www.herber.de/bbs/user/101117.xlsm
Für alle die es probieren wollen - Es soll folgendes passieren:
Beim drücken des Buttons (Berechnung) in Tabelle1 (Makro soll für alle Tabellenblätter gelten mit Ausnahme von Tabelle1),
- muss zuerst in Tabelle2 in den Spalten E:L der Inhalt gelöscht werden.
- danach muss die URL Abfrage in Tabelle2 Zelle A1 gestartet werden und den Inhalt in Zelle E1 eingefügt werden
- dann muss in Spalte I "Punkt" durch "Komma" ersetzt werden
- dann soll die Spalte I (Text in Spalte) getrennt werden und in Spalte K und Spalte L eingefügt werden und für Spalte K die Überschrift "Menge" und in Spalte L "Preis" eingetragen werden
- Zu guter Letzt müssen für die Spalten E:H die Leerzellen mit dem Text des zuletzt befüllten Feldes befüllt werden.
So sieht mein aktueller Code aus:
'


Sub Berechnung()
Dim wks As Worksheet
  For Each wks In Worksheets
    With wks
    If .Name <> "Tabelle1" Then
      .Columns("E:l").ClearContents
      With .QueryTables.Add(Connection:= _
        "URL;" & wks.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").Replace What:=".", Replacement:=",", LookAt:=xlPart, _
          SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
          ReplaceFormat:=False
        .Columns("I:I").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") = "Menge"
        .Range("L1") = "Preis"
        If .Range("E1") <> 0 Then
          Columns("E:H").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        End If
      End With
      End If
    End With
  Next wks
End Sub
'
Und dieser Ablauf soll für alle Tabelleblätter gelten (PS: zum Schluss sind es um die 100 Tabellenblätter) daher sollte das ein schneller Code sein.
IM TABELLENBLATT "MUSTER" KÖNNT IHR EUCH ANSCHAUEN, WIE ES DANN AUSSEHEN MUSS
Ich hoffe Ihr könnt mir helfen

Bild

Betrifft: AW: VBA Prozedur zu groß
von: Josef
Geschrieben am: 30.10.2015 11:50:02
erledigt

 Bild

Beiträge aus den Excel-Beispielen zum Thema "VBA Prozedur zu groß"