Sub Artikeltexte_importieren()
'Festlegung der Variablen Artikelnummer und Pfad
'der Präfix g_ ist aus optischen Gründen gewählt
'hier: g wie Guido
Dim g_Artikelnummer As String, g_TXT_Pfad As String, g_Haupttabelle As String
'Festlegung des Pfades, in dem die Artikeltextdateien sind
g_TXT_Pfad = C:\Oberordner\Unterordner\
'Festlegung des Namens der Haupttabelle
g_Haupttabelle = Musterdatei.xls
'in Spalte K sollen die Artikeltexte erscheinen
Columns(K:K).Select
'suche die erste Leere Zelle von oben
Selection.Find(What:=, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
.Activate
'gehe von dort 10 Spalten nach links
ActiveCell.Offset(0, -10).Select
Selection.Activate
'Definiere den Inhalt dieser Zelle als die Artikelnummer, die importiert werden soll
'in der Spalte seht allerdings nicht die führende Null, die im TXT-Dateinamen
'vorhanden ist daher habe ich sie hier in der Definition hinzugefügt
g_Artikelnummer = 0 & ActiveCell & .txt
'ab hier beginnt eine Schleife, die sich so lange wiederholt,
'bis keine Artikelnummer mehr ohne Artikeltext ist
Do
'wenn eine entsprechende Artikeltextdatei vorhanden ist, öffne sie
If Dir(g_TXT_Pfad & g_Artikelnummer) <> Then
'TXT-Datei öffnen ab Zeile 2 (denn in der ersten ist ja sowieso nur der
'schon in Spalte B vorhandene Artikelname
'Trennzeichen ist die geschwungene Klammer {, weil es unwahrscheinlich ist,
'daß die im Artikeltext vorkommt.
'ich habe nicht den standardmäßigen Tabulator als Trennzeichen genommen,
'weil der versehentlich oder absichtlich im Text enthalten sein könnte,
'wodurch der Inhalt nicht in einer einzigen Spalte dargestellt werden würde
Workbooks.OpenText FileName:=g_TXT_Pfad & g_Artikelnummer, _
Origin:=xlWindows, StartRow:=2, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, Other:=True, OtherChar:={, FieldInfo:= _
Array(Array(1, 2), Array(2, 1))
'Da im Artikeltext versehentlich oder absichtlich ein Zeilenumbruch vorhanden sein könnte,
'werden die untereinander stehenden Zellen per Formeln in Spalte B
'in eine Zelle zusammengefasst. Die unterste enthält dann den kompletten Text
Cells.Select
'Alle leeren Zellen, die sich möglicherweise im Bereich des Artikeltextes befinden
'(z.B. wenn im Artikeltext zwei Zeilenumbrüche hintereinander sein sollten, oder die
'leere Zeile 2, die in deinen Beispielen immer vorhanden war) werden durch §§§§§
'ersetzt. Das kommt garantiert nicht im Taxt vor und ist für Formeln leicher zu handeln
'als eine leere Zelle mittendrin. Diese Zellen werden durch die Formeln aus dem Artikeltext
'herausgefiltert.
Selection.Replace What:=, Replacement:=§§§§§, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.ColumnWidth = 45.43
With Selection
.WrapText = True
End With
Range(B1).Select
ActiveCell.FormulaR1C1 = _
=IF(RC[-1]=§§§§§,,IF(R[1]C[-1]=,RC[-1],RC[-1]& & Chr(10) & ))
Range(B2).Select
ActiveCell.FormulaR1C1 = _
=R[-1]C&IF(RC[-1]=§§§§§,,IF(R[1]C[-1]=,RC[-1],RC[-1]& & Chr(10) & ))
Range(B2).Select
Selection.Copy
Range(A1).Select
If Range(A2) = Then
Range(B2).Select
Selection.ClearContents
Else
Selection.End(xlDown).Offset(0, 1).Select
ActiveSheet.Paste
If Range(A3) = Then
Application.CutCopyMode = False
Else
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlUp)), Type:=xlFillDefault
End If
End If
Cells.Select
Cells.EntireRow.AutoFit
Range(B1).Select
If Range(B2) = Then
Range(B1).Select
Else
Selection.End(xlDown).Select
End If
Selection.Activate
g_Artikeltext = ActiveCell
'sonst weiter bei keine_Artikeltextdatei_vorhanden
Else: GoTo keine_Artikeltextdatei_vorhanden
End If
Windows(g_Haupttabelle).Activate
ActiveCell.Offset(0, 10).Select
Selection.Activate
ActiveCell.FormulaR1C1 = g_Artikeltext
Windows(g_Artikelnummer).Activate
'die TXT-Datei wird ohne Speichern wieder geschlossen
ActiveWindow.Close Savechanges:=False
GoTo Normalweiter
keine_Artikeltextdatei_vorhanden:
ActiveCell.Offset(0, 10).Select
ActiveCell.FormulaR1C1 = keine_Artikeltextdatei_vorhanden
Normalweiter:
Columns(K:K).Select
Selection.Find(What:=, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
.Activate
ActiveCell.Offset(0, -10).Select
Selection.Activate
'Die Artikelnummer wird bei jedem Durchlauf der Schleife wieder neu definiert
g_Artikelnummer = 0 & ActiveCell & .txt
'Schleife soll so lange laufen, bis in Spalte Artikelnummer kein Eintrag mehr ist
Loop While ActiveCell <>
'Alle Zellen, die keine_Artikeltextdatei_vorhanden enthalten, fett rot formatieren
'(bedingte Formatierung)
Columns(K:K).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:==keine_Artikeltextdatei_vorhanden
With Selection.FormatConditions(1).Font
.Bold = True
.ColorIndex = 3
End With
'Hier werden die Zellen so formatiert, daß der Zelleintrag am
'oberen Zellrand ausgerichtet ist und der Zeilenumbruch aktiviert ist
'Standard in Excel ist die Ausrichtung unten, was im vorliegenden Fall nicht so toll ist
Cells.Select
With Selection
.VerticalAlignment = xlTop
.WrapText = True
End With
Range(A1).Select
End Sub
