stevenow
Apr 10, 2012, updated at Apr 11, 2012 (UTC)
view3565
view24
0
Goto Top

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

GermansolvedQuestionMicrosoft OfficeMicrosoft

Hallo zusammen,

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
Nun möchte ich den html Code aber nicht komplett importieren sondern nur einen Ausschnitt
<table> bis </table>
Jemand eine Idee?
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 183324

Url: https://administrator.de/contentid/183324

Printed on: April 19, 2024 at 22:04 o'clock

24 Comments
Latest comment
Goto Top
Member: mak-xxl
mak-xxl Apr 10, 2012 at 15:48:02 (UTC)
Goto Top
Moin SteveNow,

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
Mitglied: 76109
76109 Apr 10, 2012 at 20:40:30 (UTC)
Goto Top
Hallo SteveNow!

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 Sub

Gruß Dieter

[edit]
@bastla
'ich borge auch mal kurz bei Dieter face-wink
Klauen, triffts wohl eher...face-smile
[/edit]
Member: bastla
bastla Apr 10, 2012 at 20:57:38 (UTC)
Goto Top
@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 face-wink ...
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 Inhalt
Grüße
bastla

[Edit] @Dieter
Klauen, triffts wohl eher...face-smile
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) ... face-wink
[/Edit]
Member: SteveNow
SteveNow Apr 11, 2012 at 12:33:46 (UTC)
Goto Top
Hi Mak-XXL

Bei deiner Lösung kommt ein Laufzeitfehler 5
Ungültiger Prozeduraufruf oder ungültiges Argument
Member: SteveNow
SteveNow Apr 11, 2012 at 12:38:08 (UTC)
Goto Top
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
Member: mak-xxl
mak-xxl Apr 11, 2012 at 13:21:28 (UTC)
Goto Top
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)
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
Member: mak-xxl
mak-xxl Apr 11, 2012 at 13:27:55 (UTC)
Goto Top
Moin SteveNow,

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

Freundliche Grüße von der Insel - Mario
Mitglied: 76109
76109 Apr 11, 2012 at 13:36:04 (UTC)
Goto Top
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 verbessernface-wink

Gruß Dieter

[edit] Mario war etwas schneller und hat's auch schön erklärt face-smile [/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...face-wink
Member: mak-xxl
mak-xxl Apr 11, 2012 at 13:49:37 (UTC)
Goto Top
Moin didi1954,

sorry, ich dachte, nach so einer Nachtschicht ... face-wink

Freundliche Grüße von der Insel - Mario
Member: SteveNow
SteveNow Apr 11, 2012 at 15:29:20 (UTC)
Goto Top
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.


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
Member: mak-xxl
mak-xxl Apr 11, 2012 at 15:59:37 (UTC)
Goto Top
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.

    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
Member: SteveNow
SteveNow Apr 11, 2012 at 19:24:10 (UTC)
Goto Top
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

<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'>&nbsp;</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'>&nbsp;</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'>&nbsp;</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'>&nbsp;</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'>&nbsp;</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'>&nbsp;</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'>&nbsp;</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'>&nbsp;</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>
Member: bastla
bastla Apr 11, 2012 at 19:30:00 (UTC)
Goto Top
Hallo SteveNow!
Was ist mit Zeile 4 gemeint? r = Replace(r, vbCrLf, Chr(10))
Die Zeile stand doch so schon bei Dir face-wink - 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
Member: SteveNow
SteveNow Apr 11, 2012 at 19:53:14 (UTC)
Goto Top
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 face-sad

Werd ich aber dennoch mal versuchen
Member: SteveNow
SteveNow Apr 11, 2012 at 19:55:42 (UTC)
Goto Top
doppelpost - sorry
Member: SteveNow
SteveNow Apr 11, 2012 at 19:57:11 (UTC)
Goto Top
Hier nochmal das Makro in komplett:


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
Member: mak-xxl
mak-xxl Apr 12, 2012 at 06:25:41 (UTC)
Goto Top
Moin SteveNow,

ersetze die Zeile 318 durch:
    r = Left(r, InStr(1, r, "</table>", vbTextCompare) - 1)     ' alles bis </table>

Freundliche Grüße von der Insel - Mario
Mitglied: 76109
76109 Apr 12, 2012 at 12:37:28 (UTC)
Goto Top
Hallo SteveNow!

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 Sub


Gruß Dieter

[edit] Codezeile 80/81 geändert. Jetzt komplett mit <table und </table> [/edit]
Member: SteveNow
SteveNow Apr 12, 2012 at 18:46:14 (UTC)
Goto Top
Hi,

erhalte weiterhin den selben Fehler.

@Dieter: Deins muss ich noch probieren - recht komplex das ganze ;)
Member: SteveNow
SteveNow Apr 12, 2012 at 19:50:10 (UTC)
Goto Top
Woah, Hammer!

Danke, funktioniert einwandfrei !
Mitglied: 76109
76109 Apr 13, 2012 at 06:13:06 (UTC)
Goto Top
Hallo Hallo SteveNow!

Danke, funktioniert einwandfrei !
Freu mich zu hören face-smile

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

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:
Range("A1").Value = Wert  
Cells(1,1).Value = Wert   'Cells(Zeilennumer, Spaltennummer)  
....
Wenn ein Sheet nicht Aktiv ist:
Sheets("Name").Activate  
Range("A1").Value = Wert  
Cells(1,1).Value = Wert
....
oder
Sheets("Name").Range("A1").Value = Wert  
Sheets("Name").Cells(1,1).Value = Wert    
....
oder
With Sheets("Name")  
    .Range("A1").Value = Wert  
    .Cells(1,1).Value = Wert
    ....
End With
und wenn auf 2 oder mehr Sheets zugegriffen wird, dann werden die Sheets-Objecte einer Variablen zugewiesen z.B:
Dim Wks1 As Worksheet, Wks2 As Worksheet

Set Wks1 =  Sheets("Name1")  
Set Wks2 =  Sheets("Name2")  

Wks1.Range("A1") = Wert1  
Wks2.Range("A1") = Wert2  
...
oder
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 versehenface-wink

Gruß Dieter
Member: SteveNow
SteveNow Apr 30, 2012 at 10:55:44 (UTC)
Goto Top
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?
Member: SteveNow
SteveNow Apr 30, 2012 at 11:38:23 (UTC)
Goto Top
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)

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 Sub

Noch jemand einen Vorschlag?
Mitglied: 76109
76109 Apr 30, 2012 at 18:24:20 (UTC)
Goto Top
Hallo SteveNow!

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

Gruß Dieter
GermansolvedQuestionMicrosoft OfficeMicrosoft
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 CommentsjstrickerWIREGUARD VPN ON UDM PRO BEHIND FRITZBOX - HANDSHAKE DID NOT COMPLETEjstricker - 3 CommentsDaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment