Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit

Importieren von html-code in Zelle klappt, benötige aber nur einen Ausschnitt vom Code

Frage Microsoft Microsoft Office

Mitglied: SteveNow

SteveNow (Level 1) - Jetzt verbinden

10.04.2012, aktualisiert 11.04.2012, 2771 Aufrufe, 24 Kommentare

Hallo zusammen,

hiermit importiere ich den html code einer Datei in eine Zelle.
01.
If Trim(UCase(Dir(d & "\" & f))) <> Trim(UCase(f)) Then 
02.
     
03.
    MsgBox "htmlquelldatei nicht gefunden - Nächster Artikel" 
04.
    Sheets("Makro").Activate 
05.
    Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer 
06.
    GoTo Auslesen 
07.
     
08.
   
09.
    Else 
10.
   
11.
    '   Handle... 
12.
     
13.
        h = FreeFile 
14.
     
15.
    '   Öffnen... 
16.
     
17.
        Open d & "\" & f For Binary Access Read As #h 
18.
     
19.
    '   Init... 
20.
     
21.
        r = String(FileLen(d & "\" & f), " ") 
22.
     
23.
    '   Lesen... 
24.
     
25.
        Get #h, , r 
26.
     
27.
    '   Schließen... 
28.
     
29.
        Close #h 
30.
     
31.
    '   Aufräumen... 
32.
     
33.
        r = Replace(r, vbCrLf, Chr(10)) 
34.
          
35.
        Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate 
36.
        Sheets("Tabelle1").Activate 
37.
        Range("AA" & Eigenschaftsgruppenzaehler).Value = r 
38.
         
39.
        'Export in .html umbezeichnen 
40.
        Name Speicherpfad & Artikelnummer & ".txt" As Speicherpfad & Artikelnummer & ".htm" 
41.
 
42.
    End If
Nun möchte ich den html Code aber nicht komplett importieren sondern nur einen Ausschnitt
<table> bis </table>
Jemand eine Idee?
Mitglied: mak-xxl
10.04.2012 um 17:48 Uhr
Moin SteveNow,

unter der Annahme, das in Deinem html nur eine Tabelle existiert?, etwa so:

01.
... 
02.
    r = Mid(r, InStr(1, r, "<table", vbTextCompare) + 6)       ' alles nach <table 
03.
    r = Mid(r, InStr(1, r, ">", vbTextCompare) + 1)            ' alles nach > 
04.
    r = Mid(r, 1, InStr(1, r, "</table>", vbTextCompare) - 1)  ' alles bis </table> 
05.
    r = Replace(r, vbCrLf, Chr(10))                            ' Deine Zeile 
06.
...
Die ersten beiden Zeilen sind notwendig, falls im <table>-Tag noch weitere Attribute notiert sind (und weil RegEx in Excel-VBA nicht mit einer Zeile zu erledigen ist):

01.
<table border="1" cellspacing="2">
PS: Benutze bitte die <code>-Tags beim Posten von Quelltext - auch nachträglich.

Freundliche Grüße von der Insel - Mario
Bitte warten ..
Mitglied: 76109
10.04.2012 um 22:40 Uhr
Hallo SteveNow!

Anderes Beispiel ohne RegExp:
01.
Option Compare Text 
02.
 
03.
Const Tag1 = "<table>" 
04.
Const Tag2 = "</table>" 
05.
 
06.
Const Text = "IrgendEinText<table>Dein Text</table>NochIrgendEinText" 
07.
 
08.
Sub Test() 
09.
    Dim Result As String 
10.
 
11.
    If InStr(Text, Tag1) > 0 And InStr(Text, Tag2) > 0 Then 
12.
        Result = Split(Split(Text, Tag1)(1), Tag2)(0)  'Ergebnis in Result = "Dein Text" 
13.
    Else 
14.
        Result = "Nothing" 
15.
    End If 
16.
  
17.
    MsgBox Result 
18.
End Sub
Gruß Dieter

[edit]
@bastla
'ich borge auch mal kurz bei Dieter
Klauen, triffts wohl eher...
[/edit]
Bitte warten ..
Mitglied: bastla
10.04.2012 um 22:57 Uhr
@Mario
und weil RegEx in Excel-VBA nicht mit einer Zeile zu erledigen ist
Naja, mehr als eine Zeile war's bei Dir ja auch ...
01.
r = "IrgendEinText<table border=""1"" cellspacing=""2"">Dein Text</table>NochIrgendEinText" 'ich borge auch mal kurz bei Dieter ;-) 
02.
 
03.
Set rE = CreateObject("VbScript.RegExp") 
04.
rE.Pattern = "<table.*>(.+)</table>" 
05.
If rE.Test(r) Then Inhalt = rE.Execute(r)(0).SubMatches(0) 
06.
 
07.
MsgBox Inhalt
Grüße
bastla

[Edit] @Dieter
Klauen, triffts wohl eher...
Aber nein - kannst Du ja jederzeit wieder zurück haben (und Mario wird Dir, wie ich ihn einschätze, seine Zusätze sicherlich auch noch überlassen) ...
[/Edit]
Bitte warten ..
Mitglied: SteveNow
11.04.2012 um 14:33 Uhr
Hi Mak-XXL

Bei deiner Lösung kommt ein Laufzeitfehler 5
Ungültiger Prozeduraufruf oder ungültiges Argument
Bitte warten ..
Mitglied: SteveNow
11.04.2012 um 14:38 Uhr
Grüß dich didi 1954 !

Die Messagebox gibt mir "Dein Text" zurück ? oO

Bin leider nicht so der Makro-Crack, die Basics sitzen, aber das ist mir hier etwas zu hoch ^^

Was macht dein Makro genau?
Und wie ist das hier zu verstehen

Const Text = "IrgendEinText<table>Dein Text</table>NochIrgendEinText"

Liebe Grüße
Bitte warten ..
Mitglied: mak-xxl
11.04.2012 um 15:21 Uhr
Moin SteveNow,

ich antworte mal anstelle von didi1954, damit Du nicht solange warten musst:

Die Rückgabe von 'DeinText' liegt daran, das in dem Vorschlag lediglich eine mögliche Vorgehensweise beschrieben wird, die aber nicht an oder auf die von Dir bereits geposteten Zeilen angepasst oder bezogen ist. Ein innerhalb der <table>-Tags stehender Mustertext (siehe Zeile 6)
01.
Const Text = "IrgendEinText<table>Dein Text</table>NochIrgendEinText" 
wird entspr. aufbereitet - übrig bleibt: s.o.
Die Lösung berücksichtigt aber nicht eventuelle, im <table>-Tag stehende Attribute (siehe dazu meinen 1. Post).

Freundliche Grüße von der Insel - Mario
Bitte warten ..
Mitglied: mak-xxl
11.04.2012 um 15:27 Uhr
Moin SteveNow,

dann poste mal bitte die Zeile, bei der besagter Fehler auftritt.

Freundliche Grüße von der Insel - Mario
Bitte warten ..
Mitglied: 76109
11.04.2012 um 15:36 Uhr
Hallo SteveNow!

Naja, die Codezeile mit dem Splits gibt das zurück, was zwischen den Table-Tags steht, wobei das aber nur funktioniert, wenn die Tags immer gleich sind d.h. der Tag1 (<table...>) muß in allen Html-Dateien identisch sein. Insofern, ist bastlas Lösung mit RegExp die bessere und sichere Variante.

Bleibt aber noch die Frage offen, ob die Html-Datei immer nur 1 Table enthält?

Wäre auch nicht schlecht, wenn Du den kompletten Code-Abschnitt von Sub-Begin bis Sub-Ende posten würdest, denn da ließe sich einiges wesentlich verbessern

Gruß Dieter

[edit] Mario war etwas schneller und hat's auch schön erklärt [/edit]

@bastla
Aber nein - kannst Du ja jederzeit wieder zurück haben (und Mario wird Dir, wie ich ihn einschätze, seine Zusätze sicherlich auch noch überlassen) ...
Nö danke, der ist jetzt abgenutzt und Du darfst ihn gerne behalten...
Bitte warten ..
Mitglied: mak-xxl
11.04.2012 um 15:49 Uhr
Moin didi1954,

sorry, ich dachte, nach so einer Nachtschicht ...

Freundliche Grüße von der Insel - Mario
Bitte warten ..
Mitglied: SteveNow
11.04.2012 um 17:29 Uhr
So, hier mal das komplette Makro
Es kopiert aus 2 Tabellen eine "produkttabelle" zusammen, exportiert diese als html und importiert dann den html code in die Spalte AA.

Nun soll aber nur noch der html code von <table> bis </table> importiert werden.


01.
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate 
02.
Sheets("Makro").Activate 
03.
Speicherpfad = Range("A2").Value 
04.
 
05.
Workbooks.Open Filename:=Speicherpfad & "Vorlage.xlsx"  'xls.Datei öffnen 
06.
 
07.
Eigenschaftsgruppenzaehler = 1 
08.
Error_not_found_zaehler = 0 
09.
 
10.
 
11.
'Artikel suchen 
12.
 
13.
 
14.
Auslesen: 
15.
 
16.
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate 
17.
Sheets("Makro").Activate 
18.
Speicherpfad = Range("A2").Value 
19.
 
20.
 
21.
 
22.
Eigenschaftsgruppenzaehler = Eigenschaftsgruppenzaehler + 1 
23.
'zähler für Tabellenblatt 2 auf erste Zelle setzen 
24.
Eigenschaftsgruppenzaehler2 = 2 
25.
 
26.
 
27.
'Tabellenblatt 1 auslesen 
28.
Sheets("Tabelle1").Activate 
29.
 
30.
'Spalte H "Eigenschaftsgruppe" auslesen 
31.
Range("H" & Eigenschaftsgruppenzaehler).Activate 
32.
Eigenschaftsgruppe = ActiveCell.Value 
33.
 
34.
Range("C" & Eigenschaftsgruppenzaehler).Activate 
35.
Artikelnummer = ActiveCell.Value 
36.
'Artikelnummer ist Speicherpfad !! 
37.
 
38.
'Variablen leeren 
39.
 
40.
Eigenschaft1 = "" 
41.
Eigenschaft2 = "" 
42.
Eigenschaft3 = "" 
43.
Eigenschaft4 = "" 
44.
Eigenschaft5 = "" 
45.
Eigenschaft6 = "" 
46.
Eigenschaft7 = "" 
47.
Eigenschaft8 = "" 
48.
Eigenschaft9 = "" 
49.
Eigenschaft10 = "" 
50.
Eigenschaft11 = "" 
51.
Eigenschaft12 = "" 
52.
Eigenschaft13 = "" 
53.
Eigenschaft14 = "" 
54.
Eigenschaft15 = "" 
55.
 
56.
Eigenschaftwert1 = "" 
57.
Eigenschaftwert2 = "" 
58.
Eigenschaftwert3 = "" 
59.
Eigenschaftwert4 = "" 
60.
Eigenschaftwert5 = "" 
61.
Eigenschaftwert6 = "" 
62.
Eigenschaftwert7 = "" 
63.
Eigenschaftwert8 = "" 
64.
Eigenschaftwert9 = "" 
65.
Eigenschaftwert10 = "" 
66.
Eigenschaftwert11 = "" 
67.
Eigenschaftwert12 = "" 
68.
Eigenschaftwert13 = "" 
69.
Eigenschaftwert14 = "" 
70.
Eigenschaftwert15 = "" 
71.
 
72.
'Werte der Eigenschaften kopieren 
73.
 
74.
Range("I" & Eigenschaftsgruppenzaehler).Activate 
75.
Eigenschaftwert1 = ActiveCell.Value 
76.
Range("J" & Eigenschaftsgruppenzaehler).Activate 
77.
Eigenschaftwert2 = ActiveCell.Value 
78.
Range("K" & Eigenschaftsgruppenzaehler).Activate 
79.
Eigenschaftwert3 = ActiveCell.Value 
80.
Range("L" & Eigenschaftsgruppenzaehler).Activate 
81.
Eigenschaftwert4 = ActiveCell.Value 
82.
Range("M" & Eigenschaftsgruppenzaehler).Activate 
83.
Eigenschaftwert5 = ActiveCell.Value 
84.
Range("N" & Eigenschaftsgruppenzaehler).Activate 
85.
Eigenschaftwert6 = ActiveCell.Value 
86.
Range("O" & Eigenschaftsgruppenzaehler).Activate 
87.
Eigenschaftwert7 = ActiveCell.Value 
88.
Range("P" & Eigenschaftsgruppenzaehler).Activate 
89.
Eigenschaftwert8 = ActiveCell.Value 
90.
Range("Q" & Eigenschaftsgruppenzaehler).Activate 
91.
Eigenschaftwert9 = ActiveCell.Value 
92.
Range("R" & Eigenschaftsgruppenzaehler).Activate 
93.
Eigenschaftwert10 = ActiveCell.Value 
94.
Range("S" & Eigenschaftsgruppenzaehler).Activate 
95.
Eigenschaftwert11 = ActiveCell.Value 
96.
Range("T" & Eigenschaftsgruppenzaehler).Activate 
97.
Eigenschaftwert12 = ActiveCell.Value 
98.
Range("U" & Eigenschaftsgruppenzaehler).Activate 
99.
Eigenschaftwert13 = ActiveCell.Value 
100.
Range("V" & Eigenschaftsgruppenzaehler).Activate 
101.
Eigenschaftwert14 = ActiveCell.Value 
102.
Range("W" & Eigenschaftsgruppenzaehler).Activate 
103.
Eigenschaftwert15 = ActiveCell.Value 
104.
 
105.
 
106.
 
107.
 
108.
'Eigenschaften-felder abholen 
109.
 
110.
 
111.
Eigenschaftsgruppenzaehler2 = 1 
112.
 
113.
 
114.
Eigenschaftsgruppe_suchen: 
115.
 
116.
    If Eigenschaftsgruppenzaehler2 > 250 Then GoTo Error_not_found 
117.
    Eigenschaftsgruppenzaehler2 = Eigenschaftsgruppenzaehler2 + 1 
118.
 
119.
    Sheets("Tabelle2").Activate 
120.
    Range("A" & Eigenschaftsgruppenzaehler2).Activate 
121.
    Eigenschaftsgruppe_suche = ActiveCell.Value 
122.
 
123.
    If Eigenschaftsgruppe_suche = Eigenschaftsgruppe Then 
124.
    GoTo Kopieren: 
125.
    Else 
126.
    GoTo Eigenschaftsgruppe_suchen: 
127.
    End If 
128.
 
129.
 
130.
 
131.
 
132.
Kopieren: 
133.
 
134.
Range("C" & Eigenschaftsgruppenzaehler2).Activate 
135.
Eigenschaft1 = ActiveCell.Value 
136.
Range("D" & Eigenschaftsgruppenzaehler2).Activate 
137.
Eigenschaft2 = ActiveCell.Value 
138.
Range("E" & Eigenschaftsgruppenzaehler2).Activate 
139.
Eigenschaft3 = ActiveCell.Value 
140.
Range("F" & Eigenschaftsgruppenzaehler2).Activate 
141.
Eigenschaft4 = ActiveCell.Value 
142.
Range("G" & Eigenschaftsgruppenzaehler2).Activate 
143.
Eigenschaft5 = ActiveCell.Value 
144.
Range("H" & Eigenschaftsgruppenzaehler2).Activate 
145.
Eigenschaft6 = ActiveCell.Value 
146.
Range("I" & Eigenschaftsgruppenzaehler2).Activate 
147.
Eigenschaft7 = ActiveCell.Value 
148.
Range("J" & Eigenschaftsgruppenzaehler2).Activate 
149.
Eigenschaft8 = ActiveCell.Value 
150.
Range("K" & Eigenschaftsgruppenzaehler2).Activate 
151.
Eigenschaft9 = ActiveCell.Value 
152.
Range("L" & Eigenschaftsgruppenzaehler2).Activate 
153.
Eigenschaft10 = ActiveCell.Value 
154.
Range("M" & Eigenschaftsgruppenzaehler2).Activate 
155.
Eigenschaft11 = ActiveCell.Value 
156.
Range("N" & Eigenschaftsgruppenzaehler2).Activate 
157.
Eigenschaft12 = ActiveCell.Value 
158.
Range("O" & Eigenschaftsgruppenzaehler2).Activate 
159.
Eigenschaft13 = ActiveCell.Value 
160.
Range("P" & Eigenschaftsgruppenzaehler2).Activate 
161.
Eigenschaft14 = ActiveCell.Value 
162.
Range("Q" & Eigenschaftsgruppenzaehler2).Activate 
163.
Eigenschaft15 = ActiveCell.Value 
164.
 
165.
 
166.
 
167.
'Einfügen in Vorlage.xlsx 
168.
 
169.
Workbooks("Vorlage.xlsx").Activate 
170.
Sheets("Vorlage").Activate 
171.
 
172.
 
173.
'Eigenschaften einfügen 
174.
 
175.
Range("A1").Activate 
176.
ActiveCell.Value = Eigenschaft1 
177.
Range("A2").Activate 
178.
ActiveCell.Value = Eigenschaft2 
179.
Range("A3").Activate 
180.
ActiveCell.Value = Eigenschaft3 
181.
Range("A4").Activate 
182.
ActiveCell.Value = Eigenschaft4 
183.
Range("A5").Activate 
184.
ActiveCell.Value = Eigenschaft5 
185.
Range("A6").Activate 
186.
ActiveCell.Value = Eigenschaft6 
187.
Range("A7").Activate 
188.
ActiveCell.Value = Eigenschaft7 
189.
Range("A8").Activate 
190.
ActiveCell.Value = Eigenschaft8 
191.
Range("A9").Activate 
192.
ActiveCell.Value = Eigenschaft9 
193.
Range("A10").Activate 
194.
ActiveCell.Value = Eigenschaft10 
195.
Range("A11").Activate 
196.
ActiveCell.Value = Eigenschaft11 
197.
Range("A12").Activate 
198.
ActiveCell.Value = Eigenschaft12 
199.
Range("A13").Activate 
200.
ActiveCell.Value = Eigenschaft13 
201.
Range("A14").Activate 
202.
ActiveCell.Value = Eigenschaft14 
203.
Range("A15").Activate 
204.
ActiveCell.Value = Eigenschaft15 
205.
 
206.
'Eigenschaftswerte einfügen 
207.
 
208.
 
209.
Range("B1").Activate 
210.
ActiveCell.Value = Eigenschaftwert1 
211.
Range("B2").Activate 
212.
ActiveCell.Value = Eigenschaftwert2 
213.
Range("B3").Activate 
214.
ActiveCell.Value = Eigenschaftwert3 
215.
Range("B4").Activate 
216.
ActiveCell.Value = Eigenschaftwert4 
217.
Range("B5").Activate 
218.
ActiveCell.Value = Eigenschaftwert5 
219.
Range("B6").Activate 
220.
ActiveCell.Value = Eigenschaftwert6 
221.
Range("B7").Activate 
222.
ActiveCell.Value = Eigenschaftwert7 
223.
Range("B8").Activate 
224.
ActiveCell.Value = Eigenschaftwert8 
225.
Range("B9").Activate 
226.
ActiveCell.Value = Eigenschaftwert9 
227.
Range("B10").Activate 
228.
ActiveCell.Value = Eigenschaftwert10 
229.
Range("B11").Activate 
230.
ActiveCell.Value = Eigenschaftwert11 
231.
Range("B12").Activate 
232.
ActiveCell.Value = Eigenschaftwert12 
233.
Range("B13").Activate 
234.
ActiveCell.Value = Eigenschaftwert13 
235.
Range("B14").Activate 
236.
ActiveCell.Value = Eigenschaftwert14 
237.
Range("B15").Activate 
238.
ActiveCell.Value = Eigenschaftwert15 
239.
 
240.
 
241.
'XXXXXXX Ergebnis speichern XXXXXXX 
242.
 
243.
If Artikelnummer = "" Then GoTo Error_Artikelnummer 'wenn keine Artikelnummer eingetragen dann ende 
244.
 
245.
 
246.
strDatei = "Vorlage.xlsx" 
247.
 
248.
strDatei = Application.GetSaveAsFilename _ 
249.
    (Speicherpfad & Artikelnummer, "Webseite (*.htm;*.html), *.htm;*.html") 
250.
ActiveWorkbook.PublishObjects.Add(xlSourceRange, _ 
251.
strDatei, ActiveSheet.Name, "$A$1:$B$16", xlHtmlStatic).Publish 
252.
 
253.
 
254.
'umbezeichnen 
255.
 
256.
Name Speicherpfad & Artikelnummer & ".htm" As Speicherpfad & Artikelnummer & ".txt" 
257.
 
258.
 
259.
'XXXXXX RE-IMPORT BINARY 
260.
 
261.
    Dim d As String 
262.
    Dim f As String 
263.
    Dim r As String 
264.
    Dim t As String 
265.
   
266.
    Dim x As Long 
267.
    Dim y As Long 
268.
   
269.
    Dim h As Long 
270.
   
271.
    d = Speicherpfad 
272.
     f = Artikelnummer & ".txt"    ' Dateiname 
273.
     t = "Tabelle1"                ' Tabellenblatt Ziel 
274.
     x = 1                         ' Zeile 
275.
     y = 1                         ' Spalte 
276.
      
277.
   
278.
   
279.
If Trim(UCase(Dir(d & "\" & f))) <> Trim(UCase(f)) Then 
280.
     
281.
    MsgBox "htmlquelldatei nicht gefunden - Nächster Artikel" 
282.
    Sheets("Makro").Activate 
283.
    Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer 
284.
    GoTo Auslesen 
285.
     
286.
     
287.
'Fehlerabfrage 
288.
    Else 
289.
   
290.
    '   Handle... 
291.
     
292.
        h = FreeFile 
293.
     
294.
    '   Öffnen... 
295.
     
296.
        Open d & "\" & f For Binary Access Read As #h 
297.
     
298.
    '   Init... 
299.
     
300.
   'r = String(FileLen(d & "\" & f), " ") 
301.
 
302.
Const Tag1 = "<table>" 
303.
Const Tag2 = "</table>" 
304.
 
305.
Const Text = "IrgendEinText<table>Dein Text</table>NochIrgendEinText" 
306.
 
307.
 
308.
    Dim Result As String 
309.
 
310.
    If InStr(Text, Tag1) > 0 And InStr(Text, Tag2) > 0 Then 
311.
        Result = Split(Split(Text, Tag1)(1), Tag2)(0)  'Ergebnis in Result = "Dein Text" 
312.
    Else 
313.
        Result = "Nothing" 
314.
    End If 
315.
  
316.
    MsgBox Result 
317.
 
318.
     
319.
     
320.
     
321.
    '   Lesen... 
322.
     
323.
        Get #h, , r 
324.
     
325.
    '   Schließen... 
326.
     
327.
        Close #h 
328.
     
329.
    '   Aufräumen... 
330.
     
331.
        r = Replace(r, vbCrLf, Chr(10)) 
332.
          
333.
        Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate 
334.
        Sheets("Tabelle1").Activate 
335.
        Range("AA" & Eigenschaftsgruppenzaehler).Value = r 
336.
         
337.
        'Export in .html umbezeichnen 
338.
        Name Speicherpfad & Artikelnummer & ".txt" As Speicherpfad & Artikelnummer & ".htm" 
339.
 
340.
    End If 
341.
 
342.
 
343.
If Eigenschaftsgruppenzaehler < 2500 Then 
344.
GoTo Auslesen 
345.
Else: Exit Sub 
346.
End If 
347.
 
348.
 
349.
Error_not_found: 
350.
 
351.
    Error_not_found_zaehler = Error_not_found_zaehler + 1 
352.
 
353.
    MsgBox "Eigenschaftsgruppe nicht gefunden - Nächster Artikel" 
354.
    Sheets("Makro").Activate 
355.
    Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer 
356.
 
357.
 
358.
GoTo Auslesen 
359.
 
360.
 
361.
 
362.
Error_Artikelnummer: 
363.
 
364.
MsgBox "Keine Artikelnummer eingetragen - Ende Makro" 
365.
 
366.
 
367.
 
368.
End Sub 
369.
 
370.
 
Bitte warten ..
Mitglied: mak-xxl
11.04.2012 um 17:59 Uhr
Moin SteveNow,

es wäre einfacher für uns alle, wenn Du alle Posts beachten könntest. In meinem ersten Post habe ich eine fertige Lösung angeboten, inklusive der Stelle, wo es eingefügt werden muss.

01.
    r = Mid(r, InStr(1, r, "<table", vbTextCompare) + 6)       ' alles nach <table 
02.
    r = Mid(r, InStr(1, r, ">", vbTextCompare) + 1)            ' alles nach > 
03.
    r = Mid(r, 1, InStr(1, r, "</table>", vbTextCompare) - 1)  ' alles bis </table> 
04.
    r = Replace(r, vbCrLf, Chr(10))                            ' Deine Zeile
Leider bist Du bis jetzt nicht darauf eingegangen. Ebensowenig hast Du die Zeile gepostet, die nach Deiner Aussage einen Fehler auswirft. Sei es darum, hier nochmals ein Versuch zur Hilfe:

- aus dem soeben von Dir geposteten Quelltext entfernst Du Zeile 302 bis Zeile 316 ersatzlos.
- von dem von mir oben nochmals geposteten Quelltext kopierst Du die ersten 3 Zeilen vor Deine Zeile 331.

Das funktioniert dann mit der oben gemachten Einschränkung, die Frage dazu ('mehr als eine Tabelle?') hast Du ebenfalls noch nicht beantwotet.

Verbesserungspotential gibt es im Quelltext genug, aber das kann man angehen, wenn es Dir wichtig erscheint und Grundfunktionalität gegeben ist.

Freundliche Grüße von der Insel - Mario
Bitte warten ..
Mitglied: SteveNow
11.04.2012 um 21:24 Uhr
Hallo Mario,

entschuldige bitte.

Es gibt 1 Tabelle (2 Spalten und 15-16 Zeilen)

Die Zeile die einen Fehlercode ausgibt ist die 3. in deinem Quelltext.


Edit:
ich hab das jetzt probiert, weiterhin selber Fehler.

ich hab jetzt mal von Hand aus dem Export-File raus kopiet was ich nacher in der Zelle stehen haben möchte

01.
<table border=0 cellpadding=0 cellspacing=0 width=426 style='border-collapse: 
02.
 collapse;table-layout:fixed;width:320pt'> 
03.
 <col class=xl6310161 width=152 style='mso-width-source:userset;mso-width-alt: 
04.
 5558;width:114pt'> 
05.
 <col class=xl7210161 width=274 style='mso-width-source:userset;mso-width-alt: 
06.
 10020;width:206pt'> 
07.
 <tr height=21 style='height:15.75pt'> 
08.
  <td height=21 class=xl6410161 width=152 style='height:15.75pt;width:114pt'>Typ</td> 
09.
  <td class=xl6810161 width=274 style='border-left:none;width:206pt'>Tisch</td> 
10.
 </tr> 
11.
 <tr height=21 style='height:15.75pt'> 
12.
  <td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>Material</td> 
13.
  <td class=xl6910161 width=274 style='border-top:none;border-left:none; 
14.
  width:206pt'>Aluminium</td> 
15.
 </tr> 
16.
 <tr height=21 style='height:15.75pt'> 
17.
  <td height=21 class=xl6610161 style='height:15.75pt;border-top:none'>Belastbarkeit</td> 
18.
  <td class=xl7010161 width=274 style='border-top:none;border-left:none; 
19.
  width:206pt'>60 kg</td> 
20.
 </tr> 
21.
 <tr height=21 style='height:15.75pt'> 
22.
  <td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>Maße</td> 
23.
  <td class=xl6910161 width=274 style='border-top:none;border-left:none; 
24.
  width:206pt'>70 x 70 x 70 cm (LxBXH)</td> 
25.
 </tr> 
26.
 <tr height=21 style='height:15.75pt'> 
27.
  <td height=21 class=xl6610161 style='height:15.75pt;border-top:none'>Packmaß</td> 
28.
  <td class=xl7010161 width=274 style='border-top:none;border-left:none; 
29.
  width:206pt'>70 x 20 x 20 cm (LxBxB)</td> 
30.
 </tr> 
31.
 <tr height=21 style='height:15.75pt'> 
32.
  <td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>Gewicht</td> 
33.
  <td class=xl6910161 width=274 style='border-top:none;border-left:none; 
34.
  width:206pt'>3,4 kg</td> 
35.
 </tr> 
36.
 <tr height=60 style='height:45.0pt'> 
37.
  <td height=60 class=xl6610161 style='height:45.0pt;border-top:none'>Extras</td> 
38.
  <td class=xl7010161 width=274 style='border-top:none;border-left:none; 
39.
  width:206pt'>zusammenrollbare Tischplatte sorgt für ein kleines Packmaß, 
40.
  inklusive Umhängetasche</td> 
41.
 </tr> 
42.
 <tr height=21 style='height:15.75pt'> 
43.
  <td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>&nbsp;</td> 
44.
  <td class=xl6910161 width=274 style='border-top:none;border-left:none; 
45.
  width:206pt'>-</td> 
46.
 </tr> 
47.
 <tr height=21 style='height:15.75pt'> 
48.
  <td height=21 class=xl6610161 style='height:15.75pt;border-top:none'>&nbsp;</td> 
49.
  <td class=xl7010161 width=274 style='border-top:none;border-left:none; 
50.
  width:206pt'>-</td> 
51.
 </tr> 
52.
 <tr height=21 style='height:15.75pt'> 
53.
  <td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>&nbsp;</td> 
54.
  <td class=xl6910161 width=274 style='border-top:none;border-left:none; 
55.
  width:206pt'>-</td> 
56.
 </tr> 
57.
 <tr height=21 style='height:15.75pt'> 
58.
  <td height=21 class=xl6610161 style='height:15.75pt;border-top:none'>&nbsp;</td> 
59.
  <td class=xl7010161 width=274 style='border-top:none;border-left:none; 
60.
  width:206pt'>-</td> 
61.
 </tr> 
62.
 <tr height=21 style='height:15.75pt'> 
63.
  <td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>&nbsp;</td> 
64.
  <td class=xl6910161 width=274 style='border-top:none;border-left:none; 
65.
  width:206pt'>-</td> 
66.
 </tr> 
67.
 <tr height=21 style='height:15.75pt'> 
68.
  <td height=21 class=xl6610161 style='height:15.75pt;border-top:none'>&nbsp;</td> 
69.
  <td class=xl7010161 width=274 style='border-top:none;border-left:none; 
70.
  width:206pt'>-</td> 
71.
 </tr> 
72.
 <tr height=21 style='height:15.75pt'> 
73.
  <td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>&nbsp;</td> 
74.
  <td class=xl6910161 width=274 style='border-top:none;border-left:none; 
75.
  width:206pt'>-</td> 
76.
 </tr> 
77.
 <tr height=22 style='height:16.5pt'> 
78.
  <td height=22 class=xl6710161 style='height:16.5pt;border-top:none'>&nbsp;</td> 
79.
  <td class=xl7110161 width=274 style='border-top:none;border-left:none; 
80.
  width:206pt'>-</td> 
81.
 </tr> 
82.
 <tr height=20 style='height:15.0pt'> 
83.
  <td height=20 class=xl6310161 style='height:15.0pt'></td> 
84.
  <td class=xl7210161 width=274 style='width:206pt'></td> 
85.
 </tr> 
86.
 <![if supportMisalignedColumns]> 
87.
 <tr height=0 style='display:none'> 
88.
  <td width=152 style='width:114pt'></td> 
89.
  <td width=274 style='width:206pt'></td> 
90.
 </tr> 
91.
 <![endif]> 
92.
</table>
Bitte warten ..
Mitglied: bastla
11.04.2012 um 21:30 Uhr
Hallo SteveNow!
Was ist mit Zeile 4 gemeint? r = Replace(r, vbCrLf, Chr(10))
Die Zeile stand doch so schon bei Dir - damit werden "Windows"-Zeilenschaltungen zu Zeilen-Umbrüchen innerhalb einer Excel-Zelle gemacht.
damit wird der html quelltext eingefügt, das ist klar
ist allerdings eine nicht haltbare Behauptung ...
BTW: Mein Ansatz war nix für Dich?

Grüße
bastla
Bitte warten ..
Mitglied: SteveNow
11.04.2012 um 21:53 Uhr
Grüße Basia,

Das steht bei mir im Makro weil ich da schon einen Tip von oben gefolgt bin ;)
Deinen Lösungsansatz hab ich nicht verstanden, ich kann nur die Grundfunktionen programmieren

Werd ich aber dennoch mal versuchen
Bitte warten ..
Mitglied: SteveNow
11.04.2012 um 21:55 Uhr
doppelpost - sorry
Bitte warten ..
Mitglied: SteveNow
11.04.2012 um 21:57 Uhr
Hier nochmal das Makro in komplett:


In Zeile 318 wird folgender Fehler ausgegeben:

Laufzeitfehler 5
Ungültiger Prozeduraufruf oder ungültiges Argument

01.
Sub Kopieren() 
02.
 
03.
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate 
04.
Sheets("Makro").Activate 
05.
Speicherpfad = Range("A2").Value 
06.
 
07.
 
08.
Workbooks.Open Filename:=Speicherpfad & "Vorlage.xlsx"  'xls.Datei öffnen 
09.
 
10.
 
11.
Eigenschaftsgruppenzaehler = 1 
12.
Error_not_found_zaehler = 0 
13.
 
14.
 
15.
'Artikel suchen 
16.
 
17.
 
18.
Auslesen: 
19.
 
20.
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate 
21.
Sheets("Makro").Activate 
22.
Speicherpfad = Range("A2").Value 
23.
 
24.
 
25.
 
26.
Eigenschaftsgruppenzaehler = Eigenschaftsgruppenzaehler + 1 
27.
'zähler für Tabellenblatt 2 auf erste Zelle setzen 
28.
Eigenschaftsgruppenzaehler2 = 2 
29.
 
30.
 
31.
'Tabellenblatt 1 auslesen 
32.
Sheets("Tabelle1").Activate 
33.
 
34.
'Spalte H "Eigenschaftsgruppe" auslesen 
35.
Range("H" & Eigenschaftsgruppenzaehler).Activate 
36.
Eigenschaftsgruppe = ActiveCell.Value 
37.
 
38.
Range("C" & Eigenschaftsgruppenzaehler).Activate 
39.
Artikelnummer = ActiveCell.Value 
40.
'Artikelnummer ist Speicherpfad !! 
41.
 
42.
'Variablen leeren 
43.
 
44.
Eigenschaft1 = "" 
45.
Eigenschaft2 = "" 
46.
Eigenschaft3 = "" 
47.
Eigenschaft4 = "" 
48.
Eigenschaft5 = "" 
49.
Eigenschaft6 = "" 
50.
Eigenschaft7 = "" 
51.
Eigenschaft8 = "" 
52.
Eigenschaft9 = "" 
53.
Eigenschaft10 = "" 
54.
Eigenschaft11 = "" 
55.
Eigenschaft12 = "" 
56.
Eigenschaft13 = "" 
57.
Eigenschaft14 = "" 
58.
Eigenschaft15 = "" 
59.
 
60.
Eigenschaftwert1 = "" 
61.
Eigenschaftwert2 = "" 
62.
Eigenschaftwert3 = "" 
63.
Eigenschaftwert4 = "" 
64.
Eigenschaftwert5 = "" 
65.
Eigenschaftwert6 = "" 
66.
Eigenschaftwert7 = "" 
67.
Eigenschaftwert8 = "" 
68.
Eigenschaftwert9 = "" 
69.
Eigenschaftwert10 = "" 
70.
Eigenschaftwert11 = "" 
71.
Eigenschaftwert12 = "" 
72.
Eigenschaftwert13 = "" 
73.
Eigenschaftwert14 = "" 
74.
Eigenschaftwert15 = "" 
75.
 
76.
'Werte der Eigenschaften kopieren 
77.
 
78.
Range("I" & Eigenschaftsgruppenzaehler).Activate 
79.
Eigenschaftwert1 = ActiveCell.Value 
80.
Range("J" & Eigenschaftsgruppenzaehler).Activate 
81.
Eigenschaftwert2 = ActiveCell.Value 
82.
Range("K" & Eigenschaftsgruppenzaehler).Activate 
83.
Eigenschaftwert3 = ActiveCell.Value 
84.
Range("L" & Eigenschaftsgruppenzaehler).Activate 
85.
Eigenschaftwert4 = ActiveCell.Value 
86.
Range("M" & Eigenschaftsgruppenzaehler).Activate 
87.
Eigenschaftwert5 = ActiveCell.Value 
88.
Range("N" & Eigenschaftsgruppenzaehler).Activate 
89.
Eigenschaftwert6 = ActiveCell.Value 
90.
Range("O" & Eigenschaftsgruppenzaehler).Activate 
91.
Eigenschaftwert7 = ActiveCell.Value 
92.
Range("P" & Eigenschaftsgruppenzaehler).Activate 
93.
Eigenschaftwert8 = ActiveCell.Value 
94.
Range("Q" & Eigenschaftsgruppenzaehler).Activate 
95.
Eigenschaftwert9 = ActiveCell.Value 
96.
Range("R" & Eigenschaftsgruppenzaehler).Activate 
97.
Eigenschaftwert10 = ActiveCell.Value 
98.
Range("S" & Eigenschaftsgruppenzaehler).Activate 
99.
Eigenschaftwert11 = ActiveCell.Value 
100.
Range("T" & Eigenschaftsgruppenzaehler).Activate 
101.
Eigenschaftwert12 = ActiveCell.Value 
102.
Range("U" & Eigenschaftsgruppenzaehler).Activate 
103.
Eigenschaftwert13 = ActiveCell.Value 
104.
Range("V" & Eigenschaftsgruppenzaehler).Activate 
105.
Eigenschaftwert14 = ActiveCell.Value 
106.
Range("W" & Eigenschaftsgruppenzaehler).Activate 
107.
Eigenschaftwert15 = ActiveCell.Value 
108.
 
109.
 
110.
 
111.
 
112.
'Eigenschaften-felder abholen 
113.
 
114.
 
115.
Eigenschaftsgruppenzaehler2 = 1 
116.
 
117.
 
118.
Eigenschaftsgruppe_suchen: 
119.
 
120.
    If Eigenschaftsgruppenzaehler2 > 250 Then GoTo Error_not_found 
121.
    Eigenschaftsgruppenzaehler2 = Eigenschaftsgruppenzaehler2 + 1 
122.
 
123.
    Sheets("Tabelle2").Activate 
124.
    Range("A" & Eigenschaftsgruppenzaehler2).Activate 
125.
    Eigenschaftsgruppe_suche = ActiveCell.Value 
126.
 
127.
    If Eigenschaftsgruppe_suche = Eigenschaftsgruppe Then 
128.
    GoTo Kopieren: 
129.
    Else 
130.
    GoTo Eigenschaftsgruppe_suchen: 
131.
    End If 
132.
 
133.
 
134.
 
135.
 
136.
Kopieren: 
137.
 
138.
Range("C" & Eigenschaftsgruppenzaehler2).Activate 
139.
Eigenschaft1 = ActiveCell.Value 
140.
Range("D" & Eigenschaftsgruppenzaehler2).Activate 
141.
Eigenschaft2 = ActiveCell.Value 
142.
Range("E" & Eigenschaftsgruppenzaehler2).Activate 
143.
Eigenschaft3 = ActiveCell.Value 
144.
Range("F" & Eigenschaftsgruppenzaehler2).Activate 
145.
Eigenschaft4 = ActiveCell.Value 
146.
Range("G" & Eigenschaftsgruppenzaehler2).Activate 
147.
Eigenschaft5 = ActiveCell.Value 
148.
Range("H" & Eigenschaftsgruppenzaehler2).Activate 
149.
Eigenschaft6 = ActiveCell.Value 
150.
Range("I" & Eigenschaftsgruppenzaehler2).Activate 
151.
Eigenschaft7 = ActiveCell.Value 
152.
Range("J" & Eigenschaftsgruppenzaehler2).Activate 
153.
Eigenschaft8 = ActiveCell.Value 
154.
Range("K" & Eigenschaftsgruppenzaehler2).Activate 
155.
Eigenschaft9 = ActiveCell.Value 
156.
Range("L" & Eigenschaftsgruppenzaehler2).Activate 
157.
Eigenschaft10 = ActiveCell.Value 
158.
Range("M" & Eigenschaftsgruppenzaehler2).Activate 
159.
Eigenschaft11 = ActiveCell.Value 
160.
Range("N" & Eigenschaftsgruppenzaehler2).Activate 
161.
Eigenschaft12 = ActiveCell.Value 
162.
Range("O" & Eigenschaftsgruppenzaehler2).Activate 
163.
Eigenschaft13 = ActiveCell.Value 
164.
Range("P" & Eigenschaftsgruppenzaehler2).Activate 
165.
Eigenschaft14 = ActiveCell.Value 
166.
Range("Q" & Eigenschaftsgruppenzaehler2).Activate 
167.
Eigenschaft15 = ActiveCell.Value 
168.
 
169.
 
170.
 
171.
'Einfügen in Vorlage.xlsx 
172.
 
173.
Workbooks("Vorlage.xlsx").Activate 
174.
Sheets("Vorlage").Activate 
175.
 
176.
 
177.
'Eigenschaften einfügen 
178.
 
179.
Range("A1").Activate 
180.
ActiveCell.Value = Eigenschaft1 
181.
Range("A2").Activate 
182.
ActiveCell.Value = Eigenschaft2 
183.
Range("A3").Activate 
184.
ActiveCell.Value = Eigenschaft3 
185.
Range("A4").Activate 
186.
ActiveCell.Value = Eigenschaft4 
187.
Range("A5").Activate 
188.
ActiveCell.Value = Eigenschaft5 
189.
Range("A6").Activate 
190.
ActiveCell.Value = Eigenschaft6 
191.
Range("A7").Activate 
192.
ActiveCell.Value = Eigenschaft7 
193.
Range("A8").Activate 
194.
ActiveCell.Value = Eigenschaft8 
195.
Range("A9").Activate 
196.
ActiveCell.Value = Eigenschaft9 
197.
Range("A10").Activate 
198.
ActiveCell.Value = Eigenschaft10 
199.
Range("A11").Activate 
200.
ActiveCell.Value = Eigenschaft11 
201.
Range("A12").Activate 
202.
ActiveCell.Value = Eigenschaft12 
203.
Range("A13").Activate 
204.
ActiveCell.Value = Eigenschaft13 
205.
Range("A14").Activate 
206.
ActiveCell.Value = Eigenschaft14 
207.
Range("A15").Activate 
208.
ActiveCell.Value = Eigenschaft15 
209.
 
210.
'Eigenschaftswerte einfügen 
211.
 
212.
 
213.
Range("B1").Activate 
214.
ActiveCell.Value = Eigenschaftwert1 
215.
Range("B2").Activate 
216.
ActiveCell.Value = Eigenschaftwert2 
217.
Range("B3").Activate 
218.
ActiveCell.Value = Eigenschaftwert3 
219.
Range("B4").Activate 
220.
ActiveCell.Value = Eigenschaftwert4 
221.
Range("B5").Activate 
222.
ActiveCell.Value = Eigenschaftwert5 
223.
Range("B6").Activate 
224.
ActiveCell.Value = Eigenschaftwert6 
225.
Range("B7").Activate 
226.
ActiveCell.Value = Eigenschaftwert7 
227.
Range("B8").Activate 
228.
ActiveCell.Value = Eigenschaftwert8 
229.
Range("B9").Activate 
230.
ActiveCell.Value = Eigenschaftwert9 
231.
Range("B10").Activate 
232.
ActiveCell.Value = Eigenschaftwert10 
233.
Range("B11").Activate 
234.
ActiveCell.Value = Eigenschaftwert11 
235.
Range("B12").Activate 
236.
ActiveCell.Value = Eigenschaftwert12 
237.
Range("B13").Activate 
238.
ActiveCell.Value = Eigenschaftwert13 
239.
Range("B14").Activate 
240.
ActiveCell.Value = Eigenschaftwert14 
241.
Range("B15").Activate 
242.
ActiveCell.Value = Eigenschaftwert15 
243.
 
244.
 
245.
'XXXXXXX Ergebnis speichern XXXXXXX 
246.
 
247.
If Artikelnummer = "" Then GoTo Error_Artikelnummer 'wenn keine Artikelnummer eingetragen dann ende 
248.
 
249.
 
250.
strDatei = "Vorlage.xlsx" 
251.
 
252.
strDatei = Application.GetSaveAsFilename _ 
253.
    (Speicherpfad & Artikelnummer, "Webseite (*.htm;*.html), *.htm;*.html") 
254.
ActiveWorkbook.PublishObjects.Add(xlSourceRange, _ 
255.
strDatei, ActiveSheet.Name, "$A$1:$B$16", xlHtmlStatic).Publish 
256.
 
257.
 
258.
'umbezeichnen 
259.
 
260.
Name Speicherpfad & Artikelnummer & ".htm" As Speicherpfad & Artikelnummer & ".txt" 
261.
 
262.
 
263.
'XXXXXX RE-IMPORT BINARY 
264.
 
265.
    Dim d As String 
266.
    Dim f As String 
267.
    Dim r As String 
268.
    Dim t As String 
269.
   
270.
    Dim x As Long 
271.
    Dim y As Long 
272.
   
273.
    Dim h As Long 
274.
   
275.
    d = Speicherpfad 
276.
     f = Artikelnummer & ".txt"    ' Dateiname 
277.
     t = "Tabelle1"                ' Tabellenblatt Ziel 
278.
     x = 1                         ' Zeile 
279.
     y = 1                         ' Spalte 
280.
      
281.
   
282.
   
283.
If Trim(UCase(Dir(d & "\" & f))) <> Trim(UCase(f)) Then 
284.
     
285.
    MsgBox "htmlquelldatei nicht gefunden - Nächster Artikel" 
286.
    Sheets("Makro").Activate 
287.
    Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer 
288.
    GoTo Auslesen 
289.
     
290.
     
291.
'Fehlerabfrage 
292.
    Else 
293.
   
294.
    '   Handle... 
295.
     
296.
        h = FreeFile 
297.
     
298.
    '   Öffnen... 
299.
     
300.
        Open d & "\" & f For Binary Access Read As #h 
301.
     
302.
    '   Init... 
303.
     
304.
   'r = String(FileLen(d & "\" & f), " ") 
305.
 
306.
    '   Lesen... 
307.
     
308.
        Get #h, , r 
309.
     
310.
    '   Schließen... 
311.
     
312.
        Close #h 
313.
     
314.
    '   Aufräumen... 
315.
     
316.
        r = Mid(r, InStr(1, r, "<table", vbTextCompare) + 6)       ' alles nach <table 
317.
        r = Mid(r, InStr(1, r, ">", vbTextCompare) + 1)            ' alles nach > 
318.
        r = Mid(r, 1, InStr(1, r, "</table>", vbTextCompare) - 1)  ' alles bis </table> 
319.
        r = Replace(r, vbCrLf, Chr(10)) 
320.
          
321.
        Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate 
322.
        Sheets("Tabelle1").Activate 
323.
        Range("AA" & Eigenschaftsgruppenzaehler).Value = r 
324.
         
325.
        'Export in .html umbezeichnen 
326.
        Name Speicherpfad & Artikelnummer & ".txt" As Speicherpfad & Artikelnummer & ".htm" 
327.
 
328.
    End If 
329.
 
330.
 
331.
If Eigenschaftsgruppenzaehler < 2500 Then 
332.
GoTo Auslesen 
333.
Else: Exit Sub 
334.
End If 
335.
 
336.
 
337.
Error_not_found: 
338.
 
339.
    Error_not_found_zaehler = Error_not_found_zaehler + 1 
340.
 
341.
    MsgBox "Eigenschaftsgruppe nicht gefunden - Nächster Artikel" 
342.
    Sheets("Makro").Activate 
343.
    Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer 
344.
 
345.
 
346.
GoTo Auslesen 
347.
 
348.
 
349.
 
350.
Error_Artikelnummer: 
351.
 
352.
MsgBox "Keine Artikelnummer eingetragen - Ende Makro" 
353.
 
354.
 
355.
 
356.
End Sub 
357.
 
Bitte warten ..
Mitglied: mak-xxl
12.04.2012 um 08:25 Uhr
Moin SteveNow,

ersetze die Zeile 318 durch:
01.
    r = Left(r, InStr(1, r, "</table>", vbTextCompare) - 1)     ' alles bis </table>
Freundliche Grüße von der Insel - Mario
Bitte warten ..
Mitglied: 76109
12.04.2012 um 14:37 Uhr
Hallo SteveNow!

Wenn ich Dein Skript einigermaßen richtig verstanden habe, dann könnte es hiermit funktionieren:
01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
'Externe Pause-Funktion in Millsekunden 
05.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
06.
 
07.
Private Const EigenschaftenStart = 2 
08.
 
09.
Private Const ErrMsg1 = "Abbruch! Vorlage nicht gefunden:" & vbCr & vbCr 
10.
Private Const ErrMsg2 = "Abbruch! ArtikelNr in Tabelle 1 Zeile %1 fehlt!" 
11.
Private Const ErrMsg3 = "Datei nicht gefunden:" & vbCr & vbCr 
12.
 
13.
Sub Kopieren() 
14.
    Dim Fso As Object, Wks1 As Worksheet, Wks2 As Worksheet, WksV As Worksheet 
15.
    Dim Found As Range, Eigenschaft As Variant, Eigenschaftswert As Variant 
16.
    Dim Speicherpfad As String, Path As String, ArtikelNr As String, HtmText As String 
17.
    Dim TableText As String, c As Integer, i As Long, ErrCounter As Long 
18.
     
19.
    Set Fso = CreateObject("Scripting.FileSystemObject")    'Klasse mit Dateifunktionen einbinden 
20.
     
21.
    Speicherpfad = Sheets("Makro").Range("A2").Value        'Speicherpfad festlegen 
22.
     
23.
    If Right(Speicherpfad, 1) <> "\" Then Speicherpfad = Speicherpfad & "\" 
24.
     
25.
    Path = Speicherpfad & "Vorlage.xlsx" 
26.
     
27.
    If Fso.FileExists(Path) = False Then    'Test ob Vorlage-Datei existiert, ansonsten Abbrechen 
28.
        MsgBox ErrMsg1 & Path, vbExclamation, "Fehler...":   Exit Sub 
29.
    End If 
30.
    
31.
    With Workbooks.Open(Path)   'Vorlage-Sheet importieren (wird am Ende wieder entfernt) 
32.
        .Sheets("Vorlage").Copy After:=ThisWorkbook.Sheets("Tabelle2") 
33.
        .Close False 
34.
    End With 
35.
 
36.
    Set Wks1 = Sheets("Tabelle1")   'Tabelle 1 zuweisen 
37.
    Set Wks2 = Sheets("Tabelle2")   'Tabelle 2 zuweisen 
38.
    Set WksV = Sheets("Vorlage")    'Tabelle Vorlage zuweisen 
39.
     
40.
   'Schleife bis zur letzten Zeile mit Inhalt in Tabelle 1 Spalte H 
41.
    For i = EigenschaftenStart To Wks1.Cells(Wks1.Rows.Count, "H").End(xlUp).Row 
42.
        ArtikelNr = Wks1.Cells(i, "C") 
43.
             
44.
        If ArtikelNr = "" Then  'Test ob ArtikelNr eingetragen ist, ansonsten abbrechen 
45.
            MsgBox Replace(ErrMsg2, "%1", i), vbExclamation, "Fehler...":   GoTo CleanUp 
46.
        End If 
47.
             
48.
       'Eigenschaftsgruppe in Tabelle 2 suchen 
49.
        Set Found = Wks2.Columns("A").Find(Wks1.Cells(i, "H"), LookIn:=xlValues, LookAt:=xlWhole) 
50.
         
51.
       'Test ob Eigenschaftsgruppe in Tabelle 2 vorhanden, ansonsten ArtikelNr in Sheet Makro eintragen (A10+) 
52.
        If Found Is Nothing Then 
53.
            Sheets("Makro").Range("A10").Offset(ErrCounter, 0) = ArtikelNr 
54.
            ErrCounter = ErrCounter + 1 
55.
        Else 
56.
            Eigenschaft = Wks2.Cells(Found.Row, "C").Resize(1, 15).Value    'Werte laden: Tabelle 2 Spalte C:Q 
57.
            Eigenschaftswert = Wks1.Cells(i, "I").Resize(1, 15).Value       'Werte laden: Tabelle 1 Spalte I:W 
58.
     
59.
            For c = 1 To UBound(Eigenschaft, 2) 'Werte in Sheet Vorlage eintragen 
60.
                With WksV 
61.
                    .Cells(c, "A") = Eigenschaft(1, c) 
62.
                    .Cells(c, "B") = Eigenschaftswert(1, c) 
63.
               End With 
64.
            Next 
65.
         
66.
            Path = Speicherpfad & ArtikelNr & ".htm"    'Htm-Pfad festlegen 
67.
             
68.
           'Vorlage als ArtikelNr-Htm speichern 
69.
            ThisWorkbook.PublishObjects.Add(xlSourceRange, Path, "Vorlage", "$A$1:$B$15", xlHtmlStatic).Publish 
70.
             
71.
            'Sleep 500  'falls nötig, Kommentar am Zeilenanfang entfernen 
72.
             
73.
            If Fso.FileExists(Path) Then    'Test ob Htm-Datei gespeichert wurde 
74.
                With Fso.OpenTextFile(Path) 
75.
                    HtmText = .ReadAll      'Htm-Datei einlesen 
76.
                   .Close 
77.
                End With 
78.
         
79.
               'Table-Inhalt entsprechend filtern 
80.
                TableText = "<table" & Split(Split(HtmText, "<table", 2)(1), "</table>", 2)(0) & "</table>"  
81.
             
82.
                Wks1.Cells(i, "AA") = TableText 'Table-Text in Tabelle 1 eintragen 
83.
            Else 
84.
                MsgBox ErrMsg3 & Path, vbExclamation, "Fehler..." 
85.
            End If 
86.
        End If 
87.
    Next 
88.
     
89.
CleanUp: 
90.
    With Application 
91.
        .DisplayAlerts = False 
92.
         WksV.Delete 
93.
        .DisplayAlerts = True 
94.
    End With 
95.
End Sub

Gruß Dieter

[edit] Codezeile 80/81 geändert. Jetzt komplett mit <table und </table> [/edit]
Bitte warten ..
Mitglied: SteveNow
12.04.2012 um 20:46 Uhr
Hi,

erhalte weiterhin den selben Fehler.

@Dieter: Deins muss ich noch probieren - recht komplex das ganze ;)
Bitte warten ..
Mitglied: SteveNow
12.04.2012 um 21:50 Uhr
Woah, Hammer!

Danke, funktioniert einwandfrei !
Bitte warten ..
Mitglied: 76109
13.04.2012 um 08:13 Uhr
Hallo Hallo SteveNow!

Danke, funktioniert einwandfrei !
Freu mich zu hören

@Dieter: Deins muss ich noch probieren - recht komplex das ganze ;)
Das scheint nur so, weil die vielen Activate fehlen

Bei Makroaufzeichnungen, werden alle Aktivitäten aufgezeichnet d.h. Zellen aktivieren(.Activate)/selektieren (.Select). In VBA-Code ist das unnötig, weil Du die Zellen ja auf verschiedene Arten direkt ansprechen kannst z.B.:

Wenn ein Sheet Aktiv ist:
01.
Range("A1").Value = Wert 
02.
Cells(1,1).Value = Wert   'Cells(Zeilennumer, Spaltennummer) 
03.
....
Wenn ein Sheet nicht Aktiv ist:
01.
Sheets("Name").Activate 
02.
Range("A1").Value = Wert 
03.
Cells(1,1).Value = Wert 
04.
....
oder
01.
Sheets("Name").Range("A1").Value = Wert 
02.
Sheets("Name").Cells(1,1).Value = Wert   
03.
....
oder
01.
With Sheets("Name") 
02.
    .Range("A1").Value = Wert 
03.
    .Cells(1,1).Value = Wert 
04.
    .... 
05.
End With
und wenn auf 2 oder mehr Sheets zugegriffen wird, dann werden die Sheets-Objecte einer Variablen zugewiesen z.B:
01.
Dim Wks1 As Worksheet, Wks2 As Worksheet 
02.
 
03.
Set Wks1 =  Sheets("Name1") 
04.
Set Wks2 =  Sheets("Name2") 
05.
 
06.
Wks1.Range("A1") = Wert1 
07.
Wks2.Range("A1") = Wert2 
08.
...
oder
01.
Dim Wks1 As Worksheet, Wks2 As Worksheet 
02.
 
03.
Set Wks1 =  Sheets("Name1") 
04.
Set Wks2 =  Sheets("Name2") 
05.
 
06.
With Wks1 
07.
    .Range("A1") = Wert1 
08.
    .Range("A2") = Wert2 
09.
End With 
10.
 
11.
With Wks2 
12.
    .Range("A1") = Wert2 
13.
    .Range("A2") = Wert2 
14.
End With 
15.
...
Und nicht vergessen, den Thread mit einem grünen Häkchen zu versehen

Gruß Dieter
Bitte warten ..
Mitglied: SteveNow
30.04.2012 um 12:55 Uhr
Grüß dich Dieter,

ich hab da nochmal eine Anpassung zu machen.
Dein Makro ist super gelaufen, brauch jetzt allerdings noch ein kleines Feature..

Es soll jetzt eine Spalte eingefügt werden diese kommt zwischen "C" und "D".
Ist ein X gesetzt wird die Zeile importiert, ist kein X gesetzt dann nicht.

Alle Eigenschaftswerte auf "Tabelle1" müssen jetzt 1 Spalte weiter rechts ausgelesen werden.

Leider komm ich mit deiner (wohl viel professionelleren) Schreibweise nicht klar..

Würde mir bitte jemand helfen?
Bitte warten ..
Mitglied: SteveNow
30.04.2012 um 13:38 Uhr
Hallöle,

ich hab jetzt in dem hübschen Makro vom DIeter etwas "rumgepfuscht" ..
Bisher läuft alles ganz gut..

Das sieht jetzt so aus:

(Zeile 50-53 + 101)

01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
'Externe Pause-Funktion in Millsekunden 
05.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
06.
 
07.
Private Const EigenschaftenStart = 2 
08.
 
09.
Private Const ErrMsg1 = "Abbruch! Vorlage nicht gefunden:" & vbCr & vbCr 
10.
Private Const ErrMsg2 = "Abbruch! ArtikelNr in Tabelle 1 Zeile %1 fehlt!" 
11.
Private Const ErrMsg3 = "Datei nicht gefunden:" & vbCr & vbCr 
12.
 
13.
Sub Kopieren2() 
14.
    Dim Fso As Object, Wks1 As Worksheet, Wks2 As Worksheet, WksV As Worksheet 
15.
    Dim Found As Range, Eigenschaft As Variant, Eigenschaftswert As Variant 
16.
    Dim Speicherpfad As String, Path As String, ArtikelNr As String, HtmText As String 
17.
    Dim TableText As String, c As Integer, i As Long, ErrCounter As Long 
18.
    Dim Export_me As Integer 
19.
     
20.
     
21.
    Set Fso = CreateObject("Scripting.FileSystemObject")    'Klasse mit Dateifunktionen einbinden 
22.
     
23.
    Speicherpfad = Sheets("Makro").Range("A2").Value        'Speicherpfad festlegen 
24.
     
25.
    If Right(Speicherpfad, 1) <> "\" Then Speicherpfad = Speicherpfad & "\" 
26.
     
27.
    Path = Speicherpfad & "Vorlage.xlsx" 
28.
     
29.
    If Fso.FileExists(Path) = False Then    'Test ob Vorlage-Datei existiert, ansonsten Abbrechen 
30.
        MsgBox ErrMsg1 & Path, vbExclamation, "Fehler...":   Exit Sub 
31.
    End If 
32.
    
33.
    With Workbooks.Open(Path)   'Vorlage-Sheet importieren (wird am Ende wieder entfernt) 
34.
        .Sheets("Vorlage").Copy After:=ThisWorkbook.Sheets("Tabelle2") 
35.
        .Close False 
36.
    End With 
37.
 
38.
    Set Wks1 = Sheets("Tabelle1")   'Tabelle 1 zuweisen 
39.
    Set Wks2 = Sheets("Tabelle2")   'Tabelle 2 zuweisen 
40.
    Set WksV = Sheets("Vorlage")    'Tabelle Vorlage zuweisen 
41.
     
42.
     
43.
    
44.
   'Schleife bis zur letzten Zeile mit Inhalt in Tabelle 1 Spalte H 
45.
    For i = EigenschaftenStart To Wks1.Cells(Wks1.Rows.Count, "I").End(xlUp).Row 
46.
        ArtikelNr = Wks1.Cells(i, "C") 
47.
         
48.
        Export_me = Wks1.Cells(i, "D") 
49.
         
50.
        If Export_me <> 1 Then  'Abfrage ob Zeile Exportiert werden soll 
51.
        GoTo Next_Export: 
52.
        End If 
53.
                   
54.
         
55.
        If ArtikelNr = "" Then  'Test ob ArtikelNr eingetragen ist, ansonsten abbrechen 
56.
            MsgBox Replace(ErrMsg2, "%1", i), vbExclamation, "Fehler...":   GoTo CleanUp 
57.
        End If 
58.
         
59.
 
60.
             
61.
       'Eigenschaftsgruppe in Tabelle 2 suchen 
62.
        Set Found = Wks2.Columns("A").Find(Wks1.Cells(i, "I"), LookIn:=xlValues, LookAt:=xlWhole) 
63.
         
64.
       'Test ob Eigenschaftsgruppe in Tabelle 2 vorhanden, ansonsten ArtikelNr in Sheet Makro eintragen (A10+) 
65.
        If Found Is Nothing Then 
66.
            Sheets("Makro").Range("A10").Offset(ErrCounter, 0) = ArtikelNr 
67.
            ErrCounter = ErrCounter + 1 
68.
        Else 
69.
            Eigenschaft = Wks2.Cells(Found.Row, "C").Resize(1, 15).Value    'Werte laden: Tabelle 2 Spalte D:R 
70.
            Eigenschaftswert = Wks1.Cells(i, "J").Resize(1, 15).Value       'Werte laden: Tabelle 1 Spalte I:W 
71.
     
72.
            For c = 1 To UBound(Eigenschaft, 2) 'Werte in Sheet Vorlage eintragen 
73.
                With WksV 
74.
                    .Cells(c, "A") = Eigenschaft(1, c) 
75.
                    .Cells(c, "B") = Eigenschaftswert(1, c) 
76.
               End With 
77.
            Next 
78.
         
79.
            Path = Speicherpfad & ArtikelNr & ".htm"    'Htm-Pfad festlegen 
80.
             
81.
           'Vorlage als ArtikelNr-Htm speichern 
82.
            ThisWorkbook.PublishObjects.Add(xlSourceRange, Path, "Vorlage", "$A$1:$B$15", xlHtmlStatic).Publish 
83.
             
84.
            'Sleep 500  'falls nötig, Kommentar am Zeilenanfang entfernen 
85.
             
86.
            If Fso.FileExists(Path) Then    'Test ob Htm-Datei gespeichert wurde 
87.
                With Fso.OpenTextFile(Path) 
88.
                    HtmText = .ReadAll      'Htm-Datei einlesen 
89.
                   .Close 
90.
                End With 
91.
         
92.
               'Table-Inhalt entsprechend filtern 
93.
                TableText = "<table" & Split(Split(HtmText, "<table", 2)(1), "</table>", 2)(0) & "</table>" 
94.
             
95.
                Wks1.Cells(i, "AB") = TableText 'Table-Text in Tabelle 1 eintragen 
96.
            Else 
97.
                MsgBox ErrMsg3 & Path, vbExclamation, "Fehler..." 
98.
            End If 
99.
                End If 
100.
                 
101.
Next_Export: 
102.
    Next 
103.
     
104.
CleanUp: 
105.
    With Application 
106.
        .DisplayAlerts = False 
107.
         WksV.Delete 
108.
        .DisplayAlerts = True 
109.
    End With 
110.
End Sub
Noch jemand einen Vorschlag?
Bitte warten ..
Mitglied: 76109
30.04.2012 um 20:24 Uhr
Hallo SteveNow!

ich hab jetzt in dem hübschen Makro vom DIeter etwas "rumgepfuscht" ..
Bisher läuft alles ganz gut..
Das ist so OK

Gruß Dieter
Bitte warten ..
Neuester Wissensbeitrag
Festplatten, SSD, Raid

12TB written pro SSD in 2 Jahren mit RAID5 auf Hyper-VServer

Erfahrungsbericht von Lochkartenstanzer zum Thema Festplatten, SSD, Raid ...

Ähnliche Inhalte
VB for Applications
gelöst Eigener HTML-Code im UserForm (5)

Frage von Roadrunner777 zum Thema VB for Applications ...

Erkennung und -Abwehr
Port 7547 SOAP Remote Code Execution Attack Against DSL Modems Internet Storm Center (5)

Link von Lochkartenstanzer zum Thema Erkennung und -Abwehr ...

Batch & Shell
gelöst Findstr - code für schwieriger Abfrage gesucht (9)

Frage von reissaus73 zum Thema Batch & Shell ...

Heiß diskutierte Inhalte
Windows Userverwaltung
Ausgeschiedene Mitarbeiter im Unternehmen - was tun mit den AD Konten? (34)

Frage von patz223 zum Thema Windows Userverwaltung ...

LAN, WAN, Wireless
gelöst Server erkennt Client nicht wenn er ausserhalb des DHCP Pools liegt (28)

Frage von Mar-west zum Thema LAN, WAN, Wireless ...

LAN, WAN, Wireless
FritzBox, zwei Server, verschiedene Netze (21)

Frage von DavidGl zum Thema LAN, WAN, Wireless ...

Viren und Trojaner
Aufgepasst: Neue Ransomware Goldeneye verbreitet sich rasant (20)

Link von Penny.Cilin zum Thema Viren und Trojaner ...