16.02.2021, 18:04
Hallo zusammen,
ich habe mal eine Frage bzgl. eines Formatübertrags. Ich habe folgende Formel die auch soweit funktioniert (siehe unten). Diese sorgt dafür das in einem Ordner alle vorhandenen Exceltabellen in eine Tabelle übertragen werden (ausgewählte Zellen -> .Cells(ZeileZ, 1) = wksQuelle.Cells(1, 2).Value). Es werden jedoch die Zellen ohne Formatierung übernommen (z.B. nicht die Farbe, oder wenn der text durchgestrichen wurde.) Ich habe zwar schnipsel für formatübertragung gefunden, bin aber irgendwie zu ungeschickt dieses hier anzuwenden.
Kann mir diesbezüglich jemand Hilfestellung geben damit die Zellen 1:1 mit Formatierung übernommen werden?
BESTEN DANK im Voraus!
ich habe mal eine Frage bzgl. eines Formatübertrags. Ich habe folgende Formel die auch soweit funktioniert (siehe unten). Diese sorgt dafür das in einem Ordner alle vorhandenen Exceltabellen in eine Tabelle übertragen werden (ausgewählte Zellen -> .Cells(ZeileZ, 1) = wksQuelle.Cells(1, 2).Value). Es werden jedoch die Zellen ohne Formatierung übernommen (z.B. nicht die Farbe, oder wenn der text durchgestrichen wurde.) Ich habe zwar schnipsel für formatübertragung gefunden, bin aber irgendwie zu ungeschickt dieses hier anzuwenden.
Kann mir diesbezüglich jemand Hilfestellung geben damit die Zellen 1:1 mit Formatierung übernommen werden?
BESTEN DANK im Voraus!
Code:
Sub ordner_auslesen()
Dim sVerzeichnis$, sDatei$
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim ZeileZ&, FileCount&
Dim Zelle As Range
Const StartZelle$ = "A1" '1. Auszulesende Zelle in Tabelle 1
Const Schritt& = 3 'Spaltenabstand der auszulesenden Zellen
On Error GoTo Fehler
'Suchverzeichnis auswahlen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit zu durchsuchenden Dateien wählen"
.ButtonName = "Auswälen"
If .Show = -1 Then
sVerzeichnis = .SelectedItems(1)
sDatei = Dir(sVerzeichnis & Application.PathSeparator & "*.xl*")
If sDatei <> "" Then
'neue Datei mit einem Tabellenblatt für Ergebnisdaten erstellen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
'Zieltabellenblatt Objektvariable zuweisen
Set wksZiel = wbZiel.Worksheets(1)
ZeileZ = 1
With wksZiel
'Titelzeile ausfüllen
.Cells(ZeileZ, 1) = "überschrift 1"
.Cells(ZeileZ, 2) = " überschrift 2"
.Cells(ZeileZ, 3) = "Überschrift 3"
End With
End If
Application.ScreenUpdating = False
Do Until sDatei = ""
FileCount = FileCount + 1
Application.StatusBar = "Datei, laufende Nr. " & FileCount & " wird bearbeitet."
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open( _
Filename:=sVerzeichnis & Application.PathSeparator & sDatei, _
ReadOnly:=True)
Application.AskToUpdateLinks = False
'Tabelle1 Objektvariable zuweisen
Set wksQuelle = wbQuelle.Worksheets(1)
'Werte aus Blatt 1 auslesen
Set Zelle = wksQuelle.Range(StartZelle)
Do Until IsEmpty(Zelle)
If Zelle.Value <> 0 Then
ZeileZ = ZeileZ + 1
With wksZiel
'ebene3
.Cells(ZeileZ, 1) = wksQuelle.Cells(1, 2).Value
'ebene 4
.Cells(ZeileZ, 2) = wksQuelle.Cells(2, 2).Value
'kürzel
.Cells(ZeileZ, 3) = wksQuelle.Cells(3, 2).Value
End With
End If
'Nächste Zelle setzen
Set Zelle = Zelle.Offset(0, Schritt)
Loop
wbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wbQuelle = Nothing
sDatei = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Alle Dateien ausgelesen"
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Select
End With
Set wbZiel = Nothing
Set wbQuelle = Nothing
Application.StatusBar = False
Application.AskToUpdateLinks = False
End Sub
bzw. drin lassen)
