24
Importieren von html-code in Zelle klappt, benötige aber nur einen Ausschnitt vom Code
Hallo zusammen,
hiermit importiere ich den html code einer Datei in eine Zelle.
Nun möchte ich den html Code aber nicht komplett importieren sondern nur einen Ausschnitt
<table> bis </table>
Jemand eine Idee?
hiermit importiere ich den html code einer Datei in eine Zelle.
If Trim(UCase(Dir(d & "\" & f))) <> Trim(UCase(f)) Then
MsgBox "htmlquelldatei nicht gefunden - Nächster Artikel"
Sheets("Makro").Activate
Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer
GoTo Auslesen
Else
' Handle...
h = FreeFile
' Öffnen...
Open d & "\" & f For Binary Access Read As #h
' Init...
r = String(FileLen(d & "\" & f), " ")
' Lesen...
Get #h, , r
' Schließen...
Close #h
' Aufräumen...
r = Replace(r, vbCrLf, Chr(10))
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate
Sheets("Tabelle1").Activate
Range("AA" & Eigenschaftsgruppenzaehler).Value = r
'Export in .html umbezeichnen
Name Speicherpfad & Artikelnummer & ".txt" As Speicherpfad & Artikelnummer & ".htm"
End If<table> bis </table>
Jemand eine Idee?
Auf Facebook teilen
Auf Twitter teilen
Auf Reddit teilen
Auf Linkedin teilenBitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 183324
Url: https://administrator.de/contentid/183324
Ausgedruckt am: 26.11.2024 um 06:11 Uhr
24 Kommentare
Neuester Kommentar
Moin SteveNow,
unter der Annahme, das in Deinem html nur eine Tabelle existiert?, etwa so:
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):
PS: Benutze bitte die -Tags beim Posten von Quelltext - auch nachträglich.
Freundliche Grüße von der Insel - Mario
unter der Annahme, das in Deinem html nur eine Tabelle existiert?, etwa so:
...
r = Mid(r, InStr(1, r, "<table", vbTextCompare) + 6) ' alles nach <table
r = Mid(r, InStr(1, r, ">", vbTextCompare) + 1) ' alles nach >
r = Mid(r, 1, InStr(1, r, "</table>", vbTextCompare) - 1) ' alles bis </table>
r = Replace(r, vbCrLf, Chr(10)) ' Deine Zeile
...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):
<table border="1" cellspacing="2"> PS: Benutze bitte die -Tags beim Posten von Quelltext - auch nachträglich.
Freundliche Grüße von der Insel - Mario
Hallo SteveNow!
Anderes Beispiel ohne RegExp:
Gruß Dieter
[edit]
@bastla
[/edit]
Anderes Beispiel ohne RegExp:
Option Compare Text
Const Tag1 = "<table>"
Const Tag2 = "</table>"
Const Text = "IrgendEinText<table>Dein Text</table>NochIrgendEinText"
Sub Test()
Dim Result As String
If InStr(Text, Tag1) > 0 And InStr(Text, Tag2) > 0 Then
Result = Split(Split(Text, Tag1)(1), Tag2)(0) 'Ergebnis in Result = "Dein Text"
Else
Result = "Nothing"
End If
MsgBox Result
End SubGruß Dieter
[edit]
@bastla
'ich borge auch mal kurz bei Dieter 
Klauen, triffts wohl eher...[/edit]
@mario
...
Grüße
bastla
[Edit] @Dieter
[/Edit]
und weil RegEx in Excel-VBA nicht mit einer Zeile zu erledigen ist
Naja, mehr als eine Zeile war's bei Dir ja auch ...r = "IrgendEinText<table border=""1"" cellspacing=""2"">Dein Text</table>NochIrgendEinText" 'ich borge auch mal kurz bei Dieter ;-)
Set rE = CreateObject("VbScript.RegExp")
rE.Pattern = "<table.*>(.+)</table>"
If rE.Test(r) Then Inhalt = rE.Execute(r)(0).SubMatches(0)
MsgBox Inhaltbastla
[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]
Hi Mak-XXL
Bei deiner Lösung kommt ein Laufzeitfehler 5
Ungültiger Prozeduraufruf oder ungültiges Argument
Bei deiner Lösung kommt ein Laufzeitfehler 5
Ungültiger Prozeduraufruf oder ungültiges Argument
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
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
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)
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
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)
Const Text = "IrgendEinText<table>Dein Text</table>NochIrgendEinText" 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
Moin SteveNow,
dann poste mal bitte die Zeile, bei der besagter Fehler auftritt.
Freundliche Grüße von der Insel - Mario
dann poste mal bitte die Zeile, bei der besagter Fehler auftritt.
Freundliche Grüße von der Insel - Mario
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
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...
Moin didi1954,
sorry, ich dachte, nach so einer Nachtschicht ...
Freundliche Grüße von der Insel - Mario
sorry, ich dachte, nach so einer Nachtschicht ...
Freundliche Grüße von der Insel - Mario
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.
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.
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate
Sheets("Makro").Activate
Speicherpfad = Range("A2").Value
Workbooks.Open Filename:=Speicherpfad & "Vorlage.xlsx" 'xls.Datei öffnen
Eigenschaftsgruppenzaehler = 1
Error_not_found_zaehler = 0
'Artikel suchen
Auslesen:
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate
Sheets("Makro").Activate
Speicherpfad = Range("A2").Value
Eigenschaftsgruppenzaehler = Eigenschaftsgruppenzaehler + 1
'zähler für Tabellenblatt 2 auf erste Zelle setzen
Eigenschaftsgruppenzaehler2 = 2
'Tabellenblatt 1 auslesen
Sheets("Tabelle1").Activate
'Spalte H "Eigenschaftsgruppe" auslesen
Range("H" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftsgruppe = ActiveCell.Value
Range("C" & Eigenschaftsgruppenzaehler).Activate
Artikelnummer = ActiveCell.Value
'Artikelnummer ist Speicherpfad !!
'Variablen leeren
Eigenschaft1 = ""
Eigenschaft2 = ""
Eigenschaft3 = ""
Eigenschaft4 = ""
Eigenschaft5 = ""
Eigenschaft6 = ""
Eigenschaft7 = ""
Eigenschaft8 = ""
Eigenschaft9 = ""
Eigenschaft10 = ""
Eigenschaft11 = ""
Eigenschaft12 = ""
Eigenschaft13 = ""
Eigenschaft14 = ""
Eigenschaft15 = ""
Eigenschaftwert1 = ""
Eigenschaftwert2 = ""
Eigenschaftwert3 = ""
Eigenschaftwert4 = ""
Eigenschaftwert5 = ""
Eigenschaftwert6 = ""
Eigenschaftwert7 = ""
Eigenschaftwert8 = ""
Eigenschaftwert9 = ""
Eigenschaftwert10 = ""
Eigenschaftwert11 = ""
Eigenschaftwert12 = ""
Eigenschaftwert13 = ""
Eigenschaftwert14 = ""
Eigenschaftwert15 = ""
'Werte der Eigenschaften kopieren
Range("I" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert1 = ActiveCell.Value
Range("J" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert2 = ActiveCell.Value
Range("K" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert3 = ActiveCell.Value
Range("L" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert4 = ActiveCell.Value
Range("M" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert5 = ActiveCell.Value
Range("N" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert6 = ActiveCell.Value
Range("O" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert7 = ActiveCell.Value
Range("P" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert8 = ActiveCell.Value
Range("Q" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert9 = ActiveCell.Value
Range("R" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert10 = ActiveCell.Value
Range("S" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert11 = ActiveCell.Value
Range("T" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert12 = ActiveCell.Value
Range("U" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert13 = ActiveCell.Value
Range("V" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert14 = ActiveCell.Value
Range("W" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert15 = ActiveCell.Value
'Eigenschaften-felder abholen
Eigenschaftsgruppenzaehler2 = 1
Eigenschaftsgruppe_suchen:
If Eigenschaftsgruppenzaehler2 > 250 Then GoTo Error_not_found
Eigenschaftsgruppenzaehler2 = Eigenschaftsgruppenzaehler2 + 1
Sheets("Tabelle2").Activate
Range("A" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaftsgruppe_suche = ActiveCell.Value
If Eigenschaftsgruppe_suche = Eigenschaftsgruppe Then
GoTo Kopieren:
Else
GoTo Eigenschaftsgruppe_suchen:
End If
Kopieren:
Range("C" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft1 = ActiveCell.Value
Range("D" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft2 = ActiveCell.Value
Range("E" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft3 = ActiveCell.Value
Range("F" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft4 = ActiveCell.Value
Range("G" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft5 = ActiveCell.Value
Range("H" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft6 = ActiveCell.Value
Range("I" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft7 = ActiveCell.Value
Range("J" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft8 = ActiveCell.Value
Range("K" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft9 = ActiveCell.Value
Range("L" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft10 = ActiveCell.Value
Range("M" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft11 = ActiveCell.Value
Range("N" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft12 = ActiveCell.Value
Range("O" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft13 = ActiveCell.Value
Range("P" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft14 = ActiveCell.Value
Range("Q" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft15 = ActiveCell.Value
'Einfügen in Vorlage.xlsx
Workbooks("Vorlage.xlsx").Activate
Sheets("Vorlage").Activate
'Eigenschaften einfügen
Range("A1").Activate
ActiveCell.Value = Eigenschaft1
Range("A2").Activate
ActiveCell.Value = Eigenschaft2
Range("A3").Activate
ActiveCell.Value = Eigenschaft3
Range("A4").Activate
ActiveCell.Value = Eigenschaft4
Range("A5").Activate
ActiveCell.Value = Eigenschaft5
Range("A6").Activate
ActiveCell.Value = Eigenschaft6
Range("A7").Activate
ActiveCell.Value = Eigenschaft7
Range("A8").Activate
ActiveCell.Value = Eigenschaft8
Range("A9").Activate
ActiveCell.Value = Eigenschaft9
Range("A10").Activate
ActiveCell.Value = Eigenschaft10
Range("A11").Activate
ActiveCell.Value = Eigenschaft11
Range("A12").Activate
ActiveCell.Value = Eigenschaft12
Range("A13").Activate
ActiveCell.Value = Eigenschaft13
Range("A14").Activate
ActiveCell.Value = Eigenschaft14
Range("A15").Activate
ActiveCell.Value = Eigenschaft15
'Eigenschaftswerte einfügen
Range("B1").Activate
ActiveCell.Value = Eigenschaftwert1
Range("B2").Activate
ActiveCell.Value = Eigenschaftwert2
Range("B3").Activate
ActiveCell.Value = Eigenschaftwert3
Range("B4").Activate
ActiveCell.Value = Eigenschaftwert4
Range("B5").Activate
ActiveCell.Value = Eigenschaftwert5
Range("B6").Activate
ActiveCell.Value = Eigenschaftwert6
Range("B7").Activate
ActiveCell.Value = Eigenschaftwert7
Range("B8").Activate
ActiveCell.Value = Eigenschaftwert8
Range("B9").Activate
ActiveCell.Value = Eigenschaftwert9
Range("B10").Activate
ActiveCell.Value = Eigenschaftwert10
Range("B11").Activate
ActiveCell.Value = Eigenschaftwert11
Range("B12").Activate
ActiveCell.Value = Eigenschaftwert12
Range("B13").Activate
ActiveCell.Value = Eigenschaftwert13
Range("B14").Activate
ActiveCell.Value = Eigenschaftwert14
Range("B15").Activate
ActiveCell.Value = Eigenschaftwert15
'XXXXXXX Ergebnis speichern XXXXXXX
If Artikelnummer = "" Then GoTo Error_Artikelnummer 'wenn keine Artikelnummer eingetragen dann ende
strDatei = "Vorlage.xlsx"
strDatei = Application.GetSaveAsFilename _
(Speicherpfad & Artikelnummer, "Webseite (*.htm;*.html), *.htm;*.html")
ActiveWorkbook.PublishObjects.Add(xlSourceRange, _
strDatei, ActiveSheet.Name, "$A$1:$B$16", xlHtmlStatic).Publish
'umbezeichnen
Name Speicherpfad & Artikelnummer & ".htm" As Speicherpfad & Artikelnummer & ".txt"
'XXXXXX RE-IMPORT BINARY
Dim d As String
Dim f As String
Dim r As String
Dim t As String
Dim x As Long
Dim y As Long
Dim h As Long
d = Speicherpfad
f = Artikelnummer & ".txt" ' Dateiname
t = "Tabelle1" ' Tabellenblatt Ziel
x = 1 ' Zeile
y = 1 ' Spalte
If Trim(UCase(Dir(d & "\" & f))) <> Trim(UCase(f)) Then
MsgBox "htmlquelldatei nicht gefunden - Nächster Artikel"
Sheets("Makro").Activate
Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer
GoTo Auslesen
'Fehlerabfrage
Else
' Handle...
h = FreeFile
' Öffnen...
Open d & "\" & f For Binary Access Read As #h
' Init...
'r = String(FileLen(d & "\" & f), " ")
Const Tag1 = "<table>"
Const Tag2 = "</table>"
Const Text = "IrgendEinText<table>Dein Text</table>NochIrgendEinText"
Dim Result As String
If InStr(Text, Tag1) > 0 And InStr(Text, Tag2) > 0 Then
Result = Split(Split(Text, Tag1)(1), Tag2)(0) 'Ergebnis in Result = "Dein Text"
Else
Result = "Nothing"
End If
MsgBox Result
' Lesen...
Get #h, , r
' Schließen...
Close #h
' Aufräumen...
r = Replace(r, vbCrLf, Chr(10))
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate
Sheets("Tabelle1").Activate
Range("AA" & Eigenschaftsgruppenzaehler).Value = r
'Export in .html umbezeichnen
Name Speicherpfad & Artikelnummer & ".txt" As Speicherpfad & Artikelnummer & ".htm"
End If
If Eigenschaftsgruppenzaehler < 2500 Then
GoTo Auslesen
Else: Exit Sub
End If
Error_not_found:
Error_not_found_zaehler = Error_not_found_zaehler + 1
MsgBox "Eigenschaftsgruppe nicht gefunden - Nächster Artikel"
Sheets("Makro").Activate
Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer
GoTo Auslesen
Error_Artikelnummer:
MsgBox "Keine Artikelnummer eingetragen - Ende Makro"
End Sub
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.
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
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.
r = Mid(r, InStr(1, r, "<table", vbTextCompare) + 6) ' alles nach <table
r = Mid(r, InStr(1, r, ">", vbTextCompare) + 1) ' alles nach >
r = Mid(r, 1, InStr(1, r, "</table>", vbTextCompare) - 1) ' alles bis </table>
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
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
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
<table border=0 cellpadding=0 cellspacing=0 width=426 style='border-collapse:
collapse;table-layout:fixed;width:320pt'>
<col class=xl6310161 width=152 style='mso-width-source:userset;mso-width-alt:
5558;width:114pt'>
<col class=xl7210161 width=274 style='mso-width-source:userset;mso-width-alt:
10020;width:206pt'>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6410161 width=152 style='height:15.75pt;width:114pt'>Typ</td>
<td class=xl6810161 width=274 style='border-left:none;width:206pt'>Tisch</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>Material</td>
<td class=xl6910161 width=274 style='border-top:none;border-left:none;
width:206pt'>Aluminium</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6610161 style='height:15.75pt;border-top:none'>Belastbarkeit</td>
<td class=xl7010161 width=274 style='border-top:none;border-left:none;
width:206pt'>60 kg</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>Maße</td>
<td class=xl6910161 width=274 style='border-top:none;border-left:none;
width:206pt'>70 x 70 x 70 cm (LxBXH)</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6610161 style='height:15.75pt;border-top:none'>Packmaß</td>
<td class=xl7010161 width=274 style='border-top:none;border-left:none;
width:206pt'>70 x 20 x 20 cm (LxBxB)</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6510161 style='height:15.75pt;border-top:none'>Gewicht</td>
<td class=xl6910161 width=274 style='border-top:none;border-left:none;
width:206pt'>3,4 kg</td>
</tr>
<tr height=60 style='height:45.0pt'>
<td height=60 class=xl6610161 style='height:45.0pt;border-top:none'>Extras</td>
<td class=xl7010161 width=274 style='border-top:none;border-left:none;
width:206pt'>zusammenrollbare Tischplatte sorgt für ein kleines Packmaß,
inklusive Umhängetasche</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6510161 style='height:15.75pt;border-top:none'> </td>
<td class=xl6910161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6610161 style='height:15.75pt;border-top:none'> </td>
<td class=xl7010161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6510161 style='height:15.75pt;border-top:none'> </td>
<td class=xl6910161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6610161 style='height:15.75pt;border-top:none'> </td>
<td class=xl7010161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6510161 style='height:15.75pt;border-top:none'> </td>
<td class=xl6910161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6610161 style='height:15.75pt;border-top:none'> </td>
<td class=xl7010161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=21 style='height:15.75pt'>
<td height=21 class=xl6510161 style='height:15.75pt;border-top:none'> </td>
<td class=xl6910161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=22 style='height:16.5pt'>
<td height=22 class=xl6710161 style='height:16.5pt;border-top:none'> </td>
<td class=xl7110161 width=274 style='border-top:none;border-left:none;
width:206pt'>-</td>
</tr>
<tr height=20 style='height:15.0pt'>
<td height=20 class=xl6310161 style='height:15.0pt'></td>
<td class=xl7210161 width=274 style='width:206pt'></td>
</tr>
<![if supportMisalignedColumns]>
<tr height=0 style='display:none'>
<td width=152 style='width:114pt'></td>
<td width=274 style='width:206pt'></td>
</tr>
<![endif]>
</table>
Hallo SteveNow!
- damit werden "Windows"-Zeilenschaltungen zu Zeilen-Umbrüchen innerhalb einer Excel-Zelle gemacht.
BTW: Mein Ansatz war nix für Dich?
Grüße
bastla
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
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
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
doppelpost - sorry
Hier nochmal das Makro in komplett:
In Zeile 318 wird folgender Fehler ausgegeben:
Laufzeitfehler 5
Ungültiger Prozeduraufruf oder ungültiges Argument
In Zeile 318 wird folgender Fehler ausgegeben:
Laufzeitfehler 5
Ungültiger Prozeduraufruf oder ungültiges Argument
Sub Kopieren()
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate
Sheets("Makro").Activate
Speicherpfad = Range("A2").Value
Workbooks.Open Filename:=Speicherpfad & "Vorlage.xlsx" 'xls.Datei öffnen
Eigenschaftsgruppenzaehler = 1
Error_not_found_zaehler = 0
'Artikel suchen
Auslesen:
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate
Sheets("Makro").Activate
Speicherpfad = Range("A2").Value
Eigenschaftsgruppenzaehler = Eigenschaftsgruppenzaehler + 1
'zähler für Tabellenblatt 2 auf erste Zelle setzen
Eigenschaftsgruppenzaehler2 = 2
'Tabellenblatt 1 auslesen
Sheets("Tabelle1").Activate
'Spalte H "Eigenschaftsgruppe" auslesen
Range("H" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftsgruppe = ActiveCell.Value
Range("C" & Eigenschaftsgruppenzaehler).Activate
Artikelnummer = ActiveCell.Value
'Artikelnummer ist Speicherpfad !!
'Variablen leeren
Eigenschaft1 = ""
Eigenschaft2 = ""
Eigenschaft3 = ""
Eigenschaft4 = ""
Eigenschaft5 = ""
Eigenschaft6 = ""
Eigenschaft7 = ""
Eigenschaft8 = ""
Eigenschaft9 = ""
Eigenschaft10 = ""
Eigenschaft11 = ""
Eigenschaft12 = ""
Eigenschaft13 = ""
Eigenschaft14 = ""
Eigenschaft15 = ""
Eigenschaftwert1 = ""
Eigenschaftwert2 = ""
Eigenschaftwert3 = ""
Eigenschaftwert4 = ""
Eigenschaftwert5 = ""
Eigenschaftwert6 = ""
Eigenschaftwert7 = ""
Eigenschaftwert8 = ""
Eigenschaftwert9 = ""
Eigenschaftwert10 = ""
Eigenschaftwert11 = ""
Eigenschaftwert12 = ""
Eigenschaftwert13 = ""
Eigenschaftwert14 = ""
Eigenschaftwert15 = ""
'Werte der Eigenschaften kopieren
Range("I" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert1 = ActiveCell.Value
Range("J" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert2 = ActiveCell.Value
Range("K" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert3 = ActiveCell.Value
Range("L" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert4 = ActiveCell.Value
Range("M" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert5 = ActiveCell.Value
Range("N" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert6 = ActiveCell.Value
Range("O" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert7 = ActiveCell.Value
Range("P" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert8 = ActiveCell.Value
Range("Q" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert9 = ActiveCell.Value
Range("R" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert10 = ActiveCell.Value
Range("S" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert11 = ActiveCell.Value
Range("T" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert12 = ActiveCell.Value
Range("U" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert13 = ActiveCell.Value
Range("V" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert14 = ActiveCell.Value
Range("W" & Eigenschaftsgruppenzaehler).Activate
Eigenschaftwert15 = ActiveCell.Value
'Eigenschaften-felder abholen
Eigenschaftsgruppenzaehler2 = 1
Eigenschaftsgruppe_suchen:
If Eigenschaftsgruppenzaehler2 > 250 Then GoTo Error_not_found
Eigenschaftsgruppenzaehler2 = Eigenschaftsgruppenzaehler2 + 1
Sheets("Tabelle2").Activate
Range("A" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaftsgruppe_suche = ActiveCell.Value
If Eigenschaftsgruppe_suche = Eigenschaftsgruppe Then
GoTo Kopieren:
Else
GoTo Eigenschaftsgruppe_suchen:
End If
Kopieren:
Range("C" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft1 = ActiveCell.Value
Range("D" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft2 = ActiveCell.Value
Range("E" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft3 = ActiveCell.Value
Range("F" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft4 = ActiveCell.Value
Range("G" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft5 = ActiveCell.Value
Range("H" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft6 = ActiveCell.Value
Range("I" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft7 = ActiveCell.Value
Range("J" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft8 = ActiveCell.Value
Range("K" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft9 = ActiveCell.Value
Range("L" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft10 = ActiveCell.Value
Range("M" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft11 = ActiveCell.Value
Range("N" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft12 = ActiveCell.Value
Range("O" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft13 = ActiveCell.Value
Range("P" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft14 = ActiveCell.Value
Range("Q" & Eigenschaftsgruppenzaehler2).Activate
Eigenschaft15 = ActiveCell.Value
'Einfügen in Vorlage.xlsx
Workbooks("Vorlage.xlsx").Activate
Sheets("Vorlage").Activate
'Eigenschaften einfügen
Range("A1").Activate
ActiveCell.Value = Eigenschaft1
Range("A2").Activate
ActiveCell.Value = Eigenschaft2
Range("A3").Activate
ActiveCell.Value = Eigenschaft3
Range("A4").Activate
ActiveCell.Value = Eigenschaft4
Range("A5").Activate
ActiveCell.Value = Eigenschaft5
Range("A6").Activate
ActiveCell.Value = Eigenschaft6
Range("A7").Activate
ActiveCell.Value = Eigenschaft7
Range("A8").Activate
ActiveCell.Value = Eigenschaft8
Range("A9").Activate
ActiveCell.Value = Eigenschaft9
Range("A10").Activate
ActiveCell.Value = Eigenschaft10
Range("A11").Activate
ActiveCell.Value = Eigenschaft11
Range("A12").Activate
ActiveCell.Value = Eigenschaft12
Range("A13").Activate
ActiveCell.Value = Eigenschaft13
Range("A14").Activate
ActiveCell.Value = Eigenschaft14
Range("A15").Activate
ActiveCell.Value = Eigenschaft15
'Eigenschaftswerte einfügen
Range("B1").Activate
ActiveCell.Value = Eigenschaftwert1
Range("B2").Activate
ActiveCell.Value = Eigenschaftwert2
Range("B3").Activate
ActiveCell.Value = Eigenschaftwert3
Range("B4").Activate
ActiveCell.Value = Eigenschaftwert4
Range("B5").Activate
ActiveCell.Value = Eigenschaftwert5
Range("B6").Activate
ActiveCell.Value = Eigenschaftwert6
Range("B7").Activate
ActiveCell.Value = Eigenschaftwert7
Range("B8").Activate
ActiveCell.Value = Eigenschaftwert8
Range("B9").Activate
ActiveCell.Value = Eigenschaftwert9
Range("B10").Activate
ActiveCell.Value = Eigenschaftwert10
Range("B11").Activate
ActiveCell.Value = Eigenschaftwert11
Range("B12").Activate
ActiveCell.Value = Eigenschaftwert12
Range("B13").Activate
ActiveCell.Value = Eigenschaftwert13
Range("B14").Activate
ActiveCell.Value = Eigenschaftwert14
Range("B15").Activate
ActiveCell.Value = Eigenschaftwert15
'XXXXXXX Ergebnis speichern XXXXXXX
If Artikelnummer = "" Then GoTo Error_Artikelnummer 'wenn keine Artikelnummer eingetragen dann ende
strDatei = "Vorlage.xlsx"
strDatei = Application.GetSaveAsFilename _
(Speicherpfad & Artikelnummer, "Webseite (*.htm;*.html), *.htm;*.html")
ActiveWorkbook.PublishObjects.Add(xlSourceRange, _
strDatei, ActiveSheet.Name, "$A$1:$B$16", xlHtmlStatic).Publish
'umbezeichnen
Name Speicherpfad & Artikelnummer & ".htm" As Speicherpfad & Artikelnummer & ".txt"
'XXXXXX RE-IMPORT BINARY
Dim d As String
Dim f As String
Dim r As String
Dim t As String
Dim x As Long
Dim y As Long
Dim h As Long
d = Speicherpfad
f = Artikelnummer & ".txt" ' Dateiname
t = "Tabelle1" ' Tabellenblatt Ziel
x = 1 ' Zeile
y = 1 ' Spalte
If Trim(UCase(Dir(d & "\" & f))) <> Trim(UCase(f)) Then
MsgBox "htmlquelldatei nicht gefunden - Nächster Artikel"
Sheets("Makro").Activate
Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer
GoTo Auslesen
'Fehlerabfrage
Else
' Handle...
h = FreeFile
' Öffnen...
Open d & "\" & f For Binary Access Read As #h
' Init...
'r = String(FileLen(d & "\" & f), " ")
' Lesen...
Get #h, , r
' Schließen...
Close #h
' Aufräumen...
r = Mid(r, InStr(1, r, "<table", vbTextCompare) + 6) ' alles nach <table
r = Mid(r, InStr(1, r, ">", vbTextCompare) + 1) ' alles nach >
r = Mid(r, 1, InStr(1, r, "</table>", vbTextCompare) - 1) ' alles bis </table>
r = Replace(r, vbCrLf, Chr(10))
Workbooks("Beispiel_Eigenschaften_steffen.xlsm").Activate
Sheets("Tabelle1").Activate
Range("AA" & Eigenschaftsgruppenzaehler).Value = r
'Export in .html umbezeichnen
Name Speicherpfad & Artikelnummer & ".txt" As Speicherpfad & Artikelnummer & ".htm"
End If
If Eigenschaftsgruppenzaehler < 2500 Then
GoTo Auslesen
Else: Exit Sub
End If
Error_not_found:
Error_not_found_zaehler = Error_not_found_zaehler + 1
MsgBox "Eigenschaftsgruppe nicht gefunden - Nächster Artikel"
Sheets("Makro").Activate
Range("A" & 10 + Error_not_found_zaehler).Value = Artikelnummer
GoTo Auslesen
Error_Artikelnummer:
MsgBox "Keine Artikelnummer eingetragen - Ende Makro"
End Sub
Moin SteveNow,
ersetze die Zeile 318 durch:
Freundliche Grüße von der Insel - Mario
ersetze die Zeile 318 durch:
r = Left(r, InStr(1, r, "</table>", vbTextCompare) - 1) ' alles bis </table> Freundliche Grüße von der Insel - Mario
Hallo SteveNow!
Wenn ich Dein Skript einigermaßen richtig verstanden habe, dann könnte es hiermit funktionieren:
Gruß Dieter
[edit] Codezeile 80/81 geändert. Jetzt komplett mit <table und </table> [/edit]
Wenn ich Dein Skript einigermaßen richtig verstanden habe, dann könnte es hiermit funktionieren:
Option Explicit
Option Compare Text
'Externe Pause-Funktion in Millsekunden
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const EigenschaftenStart = 2
Private Const ErrMsg1 = "Abbruch! Vorlage nicht gefunden:" & vbCr & vbCr
Private Const ErrMsg2 = "Abbruch! ArtikelNr in Tabelle 1 Zeile %1 fehlt!"
Private Const ErrMsg3 = "Datei nicht gefunden:" & vbCr & vbCr
Sub Kopieren()
Dim Fso As Object, Wks1 As Worksheet, Wks2 As Worksheet, WksV As Worksheet
Dim Found As Range, Eigenschaft As Variant, Eigenschaftswert As Variant
Dim Speicherpfad As String, Path As String, ArtikelNr As String, HtmText As String
Dim TableText As String, c As Integer, i As Long, ErrCounter As Long
Set Fso = CreateObject("Scripting.FileSystemObject") 'Klasse mit Dateifunktionen einbinden
Speicherpfad = Sheets("Makro").Range("A2").Value 'Speicherpfad festlegen
If Right(Speicherpfad, 1) <> "\" Then Speicherpfad = Speicherpfad & "\"
Path = Speicherpfad & "Vorlage.xlsx"
If Fso.FileExists(Path) = False Then 'Test ob Vorlage-Datei existiert, ansonsten Abbrechen
MsgBox ErrMsg1 & Path, vbExclamation, "Fehler...": Exit Sub
End If
With Workbooks.Open(Path) 'Vorlage-Sheet importieren (wird am Ende wieder entfernt)
.Sheets("Vorlage").Copy After:=ThisWorkbook.Sheets("Tabelle2")
.Close False
End With
Set Wks1 = Sheets("Tabelle1") 'Tabelle 1 zuweisen
Set Wks2 = Sheets("Tabelle2") 'Tabelle 2 zuweisen
Set WksV = Sheets("Vorlage") 'Tabelle Vorlage zuweisen
'Schleife bis zur letzten Zeile mit Inhalt in Tabelle 1 Spalte H
For i = EigenschaftenStart To Wks1.Cells(Wks1.Rows.Count, "H").End(xlUp).Row
ArtikelNr = Wks1.Cells(i, "C")
If ArtikelNr = "" Then 'Test ob ArtikelNr eingetragen ist, ansonsten abbrechen
MsgBox Replace(ErrMsg2, "%1", i), vbExclamation, "Fehler...": GoTo CleanUp
End If
'Eigenschaftsgruppe in Tabelle 2 suchen
Set Found = Wks2.Columns("A").Find(Wks1.Cells(i, "H"), LookIn:=xlValues, LookAt:=xlWhole)
'Test ob Eigenschaftsgruppe in Tabelle 2 vorhanden, ansonsten ArtikelNr in Sheet Makro eintragen (A10+)
If Found Is Nothing Then
Sheets("Makro").Range("A10").Offset(ErrCounter, 0) = ArtikelNr
ErrCounter = ErrCounter + 1
Else
Eigenschaft = Wks2.Cells(Found.Row, "C").Resize(1, 15).Value 'Werte laden: Tabelle 2 Spalte C:Q
Eigenschaftswert = Wks1.Cells(i, "I").Resize(1, 15).Value 'Werte laden: Tabelle 1 Spalte I:W
For c = 1 To UBound(Eigenschaft, 2) 'Werte in Sheet Vorlage eintragen
With WksV
.Cells(c, "A") = Eigenschaft(1, c)
.Cells(c, "B") = Eigenschaftswert(1, c)
End With
Next
Path = Speicherpfad & ArtikelNr & ".htm" 'Htm-Pfad festlegen
'Vorlage als ArtikelNr-Htm speichern
ThisWorkbook.PublishObjects.Add(xlSourceRange, Path, "Vorlage", "$A$1:$B$15", xlHtmlStatic).Publish
'Sleep 500 'falls nötig, Kommentar am Zeilenanfang entfernen
If Fso.FileExists(Path) Then 'Test ob Htm-Datei gespeichert wurde
With Fso.OpenTextFile(Path)
HtmText = .ReadAll 'Htm-Datei einlesen
.Close
End With
'Table-Inhalt entsprechend filtern
TableText = "<table" & Split(Split(HtmText, "<table", 2)(1), "</table>", 2)(0) & "</table>"
Wks1.Cells(i, "AA") = TableText 'Table-Text in Tabelle 1 eintragen
Else
MsgBox ErrMsg3 & Path, vbExclamation, "Fehler..."
End If
End If
Next
CleanUp:
With Application
.DisplayAlerts = False
WksV.Delete
.DisplayAlerts = True
End With
End SubGruß Dieter
[edit] Codezeile 80/81 geändert. Jetzt komplett mit <table und </table> [/edit]
Hi,
erhalte weiterhin den selben Fehler.
@Dieter: Deins muss ich noch probieren - recht komplex das ganze ;)
erhalte weiterhin den selben Fehler.
@Dieter: Deins muss ich noch probieren - recht komplex das ganze ;)
Woah, Hammer!
Danke, funktioniert einwandfrei !
Danke, funktioniert einwandfrei !
Hallo Hallo SteveNow!
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:
Wenn ein Sheet nicht Aktiv ist:
oder
oder
und wenn auf 2 oder mehr Sheets zugegriffen wird, dann werden die Sheets-Objecte einer Variablen zugewiesen z.B:
oder
Und nicht vergessen, den Thread mit einem grünen Häkchen zu versehen
Gruß Dieter
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 fehlenBei 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:
Range("A1").Value = Wert
Cells(1,1).Value = Wert 'Cells(Zeilennumer, Spaltennummer)
....Sheets("Name").Activate
Range("A1").Value = Wert
Cells(1,1).Value = Wert
....Sheets("Name").Range("A1").Value = Wert
Sheets("Name").Cells(1,1).Value = Wert
....With Sheets("Name")
.Range("A1").Value = Wert
.Cells(1,1).Value = Wert
....
End WithDim Wks1 As Worksheet, Wks2 As Worksheet
Set Wks1 = Sheets("Name1")
Set Wks2 = Sheets("Name2")
Wks1.Range("A1") = Wert1
Wks2.Range("A1") = Wert2
...Dim Wks1 As Worksheet, Wks2 As Worksheet
Set Wks1 = Sheets("Name1")
Set Wks2 = Sheets("Name2")
With Wks1
.Range("A1") = Wert1
.Range("A2") = Wert2
End With
With Wks2
.Range("A1") = Wert2
.Range("A2") = Wert2
End With
...Und nicht vergessen, den Thread mit einem grünen Häkchen zu versehen
Gruß Dieter
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?
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?
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)
Noch jemand einen Vorschlag?
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)
Option Explicit
Option Compare Text
'Externe Pause-Funktion in Millsekunden
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const EigenschaftenStart = 2
Private Const ErrMsg1 = "Abbruch! Vorlage nicht gefunden:" & vbCr & vbCr
Private Const ErrMsg2 = "Abbruch! ArtikelNr in Tabelle 1 Zeile %1 fehlt!"
Private Const ErrMsg3 = "Datei nicht gefunden:" & vbCr & vbCr
Sub Kopieren2()
Dim Fso As Object, Wks1 As Worksheet, Wks2 As Worksheet, WksV As Worksheet
Dim Found As Range, Eigenschaft As Variant, Eigenschaftswert As Variant
Dim Speicherpfad As String, Path As String, ArtikelNr As String, HtmText As String
Dim TableText As String, c As Integer, i As Long, ErrCounter As Long
Dim Export_me As Integer
Set Fso = CreateObject("Scripting.FileSystemObject") 'Klasse mit Dateifunktionen einbinden
Speicherpfad = Sheets("Makro").Range("A2").Value 'Speicherpfad festlegen
If Right(Speicherpfad, 1) <> "\" Then Speicherpfad = Speicherpfad & "\"
Path = Speicherpfad & "Vorlage.xlsx"
If Fso.FileExists(Path) = False Then 'Test ob Vorlage-Datei existiert, ansonsten Abbrechen
MsgBox ErrMsg1 & Path, vbExclamation, "Fehler...": Exit Sub
End If
With Workbooks.Open(Path) 'Vorlage-Sheet importieren (wird am Ende wieder entfernt)
.Sheets("Vorlage").Copy After:=ThisWorkbook.Sheets("Tabelle2")
.Close False
End With
Set Wks1 = Sheets("Tabelle1") 'Tabelle 1 zuweisen
Set Wks2 = Sheets("Tabelle2") 'Tabelle 2 zuweisen
Set WksV = Sheets("Vorlage") 'Tabelle Vorlage zuweisen
'Schleife bis zur letzten Zeile mit Inhalt in Tabelle 1 Spalte H
For i = EigenschaftenStart To Wks1.Cells(Wks1.Rows.Count, "I").End(xlUp).Row
ArtikelNr = Wks1.Cells(i, "C")
Export_me = Wks1.Cells(i, "D")
If Export_me <> 1 Then 'Abfrage ob Zeile Exportiert werden soll
GoTo Next_Export:
End If
If ArtikelNr = "" Then 'Test ob ArtikelNr eingetragen ist, ansonsten abbrechen
MsgBox Replace(ErrMsg2, "%1", i), vbExclamation, "Fehler...": GoTo CleanUp
End If
'Eigenschaftsgruppe in Tabelle 2 suchen
Set Found = Wks2.Columns("A").Find(Wks1.Cells(i, "I"), LookIn:=xlValues, LookAt:=xlWhole)
'Test ob Eigenschaftsgruppe in Tabelle 2 vorhanden, ansonsten ArtikelNr in Sheet Makro eintragen (A10+)
If Found Is Nothing Then
Sheets("Makro").Range("A10").Offset(ErrCounter, 0) = ArtikelNr
ErrCounter = ErrCounter + 1
Else
Eigenschaft = Wks2.Cells(Found.Row, "C").Resize(1, 15).Value 'Werte laden: Tabelle 2 Spalte D:R
Eigenschaftswert = Wks1.Cells(i, "J").Resize(1, 15).Value 'Werte laden: Tabelle 1 Spalte I:W
For c = 1 To UBound(Eigenschaft, 2) 'Werte in Sheet Vorlage eintragen
With WksV
.Cells(c, "A") = Eigenschaft(1, c)
.Cells(c, "B") = Eigenschaftswert(1, c)
End With
Next
Path = Speicherpfad & ArtikelNr & ".htm" 'Htm-Pfad festlegen
'Vorlage als ArtikelNr-Htm speichern
ThisWorkbook.PublishObjects.Add(xlSourceRange, Path, "Vorlage", "$A$1:$B$15", xlHtmlStatic).Publish
'Sleep 500 'falls nötig, Kommentar am Zeilenanfang entfernen
If Fso.FileExists(Path) Then 'Test ob Htm-Datei gespeichert wurde
With Fso.OpenTextFile(Path)
HtmText = .ReadAll 'Htm-Datei einlesen
.Close
End With
'Table-Inhalt entsprechend filtern
TableText = "<table" & Split(Split(HtmText, "<table", 2)(1), "</table>", 2)(0) & "</table>"
Wks1.Cells(i, "AB") = TableText 'Table-Text in Tabelle 1 eintragen
Else
MsgBox ErrMsg3 & Path, vbExclamation, "Fehler..."
End If
End If
Next_Export:
Next
CleanUp:
With Application
.DisplayAlerts = False
WksV.Delete
.DisplayAlerts = True
End With
End SubNoch jemand einen Vorschlag?
Hallo SteveNow!
Gruß Dieter
ich hab jetzt in dem hübschen Makro vom DIeter etwas "rumgepfuscht" ..
Bisher läuft alles ganz gut..
Das ist so OKBisher läuft alles ganz gut..
Gruß Dieter
