Supportnet / Forum / Tabellenkalkulation
Verbessern eines Makros
Frage
Guten Morgen liebe Community,
ich habe ein Marko und habe es mit eurer Hilfe schon verbessert, doch jetzt fällt mir noch eine Verbesserung ein:
Und zwar wollte ich anfangs nur in einem Ordner nach Dateien suchen und jetzt doch in mehreren Ordner.
Alle drei Ordner liegen
Also so ca
K:\Grafik\Eigene Dateien
K:\Grafik\Eigene Dateien\Andrucke
K:\Grafik\Eigene Dateien\Produktion
Kann man es so einrichten das die 3 verschiedenen Ordner irgendwie gekennzeichnet sind ????
Sub daten_uebernehmen()
Dim Dateien As Integer
Dim loZeile As Long
Dim strPfad As String
loZeile = 2
strPfad = "K:\Grafik" '
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = strPfad
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
Datei = Mid(.FoundFiles(Dateien), Len(.LookIn) + 2, Len(.FoundFiles(Dateien)))
Cells(loZeile, 1) = Datei
Cells(loZeile, 1).Hyperlinks.Add Anchor:=Cells(loZeile, 1), Address:=strPfad & "\" & Datei, TextToDisplay:=Datei
Cells(loZeile, 2).FormulaLocal = "='" & strPfad & "\" & "[" & Datei & "]Tabelle1'!D2"
Cells(loZeile, 3).FormulaLocal = "='" & strPfad & "\" & "[" & Datei & "]Tabelle1'!H13"
Cells(loZeile, 4).FormulaLocal = "='" & strPfad & "\" & "[" & Datei & "]Tabelle1'!H14"
loZeile = loZeile + 1
Next Dateien
End If
End With
Range("B2:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).Copy
Range("B2").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
End Sub
Thx im voraus
Lg an Beverly und DukeNT
Antwort 1 von Hajo_Zi
Hallo Unbekannter,
mal ungetestet.
Option Explicit
Sub daten_uebernehmen()
Dim Dateien As Integer
Dim loZeile As Long
' Dim strPfad As String
Dim StOrdner
Dim Lol As Long
Dim Datei As String
StOrdner = Array("K:\Grafik", "K:\Grafik\Eigene Dateien", "K:\Grafik\Eigene Dateien\Andrucke", "K:\Grafik\Eigene Dateien\Produktion")
loZeile = 2
' strPfad = "K:\Grafik" '
Application.DisplayAlerts = False
With Application.FileSearch
For Lol = 0 To UBound(StOrdner())
.NewSearch
.LookIn = StOrdner(Lol)
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
Datei = Mid(.FoundFiles(Dateien), Len(.LookIn) + 2, Len(.FoundFiles(Dateien)))
Cells(loZeile, 1) = Datei
Cells(loZeile, 1).Hyperlinks.Add Anchor:=Cells(loZeile, 1), Address:=StOrdner(Lol) & "\" & Datei, TextToDisplay:=Datei
Cells(loZeile, 2).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!D2"
Cells(loZeile, 3).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H13"
Cells(loZeile, 4).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H14"
loZeile = loZeile + 1
Next Dateien
End If
Next
End With
Range("B2:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).Copy
Range("B2").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
End Sub
Gruß Hajo
mal ungetestet.
Option Explicit
Sub daten_uebernehmen()
Dim Dateien As Integer
Dim loZeile As Long
' Dim strPfad As String
Dim StOrdner
Dim Lol As Long
Dim Datei As String
StOrdner = Array("K:\Grafik", "K:\Grafik\Eigene Dateien", "K:\Grafik\Eigene Dateien\Andrucke", "K:\Grafik\Eigene Dateien\Produktion")
loZeile = 2
' strPfad = "K:\Grafik" '
Application.DisplayAlerts = False
With Application.FileSearch
For Lol = 0 To UBound(StOrdner())
.NewSearch
.LookIn = StOrdner(Lol)
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
Datei = Mid(.FoundFiles(Dateien), Len(.LookIn) + 2, Len(.FoundFiles(Dateien)))
Cells(loZeile, 1) = Datei
Cells(loZeile, 1).Hyperlinks.Add Anchor:=Cells(loZeile, 1), Address:=StOrdner(Lol) & "\" & Datei, TextToDisplay:=Datei
Cells(loZeile, 2).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!D2"
Cells(loZeile, 3).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H13"
Cells(loZeile, 4).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H14"
loZeile = loZeile + 1
Next Dateien
End If
Next
End With
Range("B2:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).Copy
Range("B2").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
End Sub
Gruß Hajo
Antwort 2 von Sp|n.aT
habs mal getestet
Fehlermeldung:
Index ausserhalb des gültigen Bereichs
hab meinen Namen vergessen
sorry
lg Martin
Ps: Thx im voraus
Fehlermeldung:
Index ausserhalb des gültigen Bereichs
hab meinen Namen vergessen
sorry
lg Martin
Ps: Thx im voraus
Antwort 3 von Hajo_Zi
Hallo Marin,
neuer versuch
Option Explicit
Sub daten_uebernehmen()
Dim Dateien As Integer
Dim loZeile As Long
' Dim strPfad As String
Dim StOrdner
Dim Lol As Long
Dim Datei As String
StOrdner = Array("C:\Eigene Dateien\Dienstreisen", "C:\Eigene Dateien")
'For Lol = 0 To 1
' MsgBox StOrdner(Lol)
' MsgBox UBound(StOrdner)
'Next Lol
loZeile = 2
' strPfad = "K:\Grafik" '
Application.DisplayAlerts = False
With Application.FileSearch
Dim StAktuell As String
'For Each StAktuell In StOrdner()
For Lol = 0 To UBound(StOrdner)
.NewSearch
.LookIn = StOrdner(Lol)
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
Datei = Mid(.FoundFiles(Dateien), Len(.LookIn) + 2, Len(.FoundFiles(Dateien)))
Cells(loZeile, 1) = Datei
Cells(loZeile, 1).Hyperlinks.Add Anchor:=Cells(loZeile, 1), Address:=StOrdner(Lol) & "\" & Datei, TextToDisplay:=Datei
Cells(loZeile, 2).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!D2"
Cells(loZeile, 3).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H13"
Cells(loZeile, 4).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H14"
loZeile = loZeile + 1
Next Dateien
End If
Next
End With
Range("B2:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).Copy
Range("B2").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
End Sub
Gruß Hajo
neuer versuch
Option Explicit
Sub daten_uebernehmen()
Dim Dateien As Integer
Dim loZeile As Long
' Dim strPfad As String
Dim StOrdner
Dim Lol As Long
Dim Datei As String
StOrdner = Array("C:\Eigene Dateien\Dienstreisen", "C:\Eigene Dateien")
'For Lol = 0 To 1
' MsgBox StOrdner(Lol)
' MsgBox UBound(StOrdner)
'Next Lol
loZeile = 2
' strPfad = "K:\Grafik" '
Application.DisplayAlerts = False
With Application.FileSearch
Dim StAktuell As String
'For Each StAktuell In StOrdner()
For Lol = 0 To UBound(StOrdner)
.NewSearch
.LookIn = StOrdner(Lol)
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
Datei = Mid(.FoundFiles(Dateien), Len(.LookIn) + 2, Len(.FoundFiles(Dateien)))
Cells(loZeile, 1) = Datei
Cells(loZeile, 1).Hyperlinks.Add Anchor:=Cells(loZeile, 1), Address:=StOrdner(Lol) & "\" & Datei, TextToDisplay:=Datei
Cells(loZeile, 2).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!D2"
Cells(loZeile, 3).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H13"
Cells(loZeile, 4).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H14"
loZeile = loZeile + 1
Next Dateien
End If
Next
End With
Range("B2:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).Copy
Range("B2").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
End Sub
Gruß Hajo
Antwort 4 von Sp|n.aT
Hi Hajo,
bei zweiten Versucht hats tadellos geklappt.
THX
Nur um nochmal auf die Frage zurückzukommen, ob man die einzelnen Dateien irgendwie farblich markieren kann ???
Ist das überhaupt möglich ???
bis später
danke im voraus
lg Martin
bei zweiten Versucht hats tadellos geklappt.
THX
Nur um nochmal auf die Frage zurückzukommen, ob man die einzelnen Dateien irgendwie farblich markieren kann ???
Ist das überhaupt möglich ???
bis später
danke im voraus
lg Martin
Antwort 5 von Hajo_Zi
Hallo Martin,
das ist wohl untergegangen.
Option Explicit
Sub daten_uebernehmen()
Dim Dateien As Integer
Dim loZeile As Long
' Dim strPfad As String
Dim StOrdner
Dim Lol As Long
Dim Datei As String
Dim InFarbe As Integer
InFarbe = 2
StOrdner = Array("C:\Eigene Dateien\Dienstreisen", "C:\Eigene Dateien")
'For Lol = 0 To 1
' MsgBox StOrdner(Lol)
' MsgBox UBound(StOrdner)
'Next Lol
loZeile = 2
' strPfad = "K:\Grafik" '
Application.DisplayAlerts = False
With Application.FileSearch
Dim StAktuell As String
'For Each StAktuell In StOrdner()
For Lol = 0 To UBound(StOrdner)
.NewSearch
.LookIn = StOrdner(Lol)
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
Datei = Mid(.FoundFiles(Dateien), Len(.LookIn) + 2, Len(.FoundFiles(Dateien)))
Cells(loZeile, 1) = Datei
Cells(loZeile, 1).Hyperlinks.Add Anchor:=Cells(loZeile, 1), Address:=StOrdner(Lol) & "\" & Datei, TextToDisplay:=Datei
Cells(loZeile, 2).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!D2"
Cells(loZeile, 3).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H13"
Cells(loZeile, 4).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H14"
Range(Cells(loZeile, 1), Cells(loZeile, 4)).Interior.ColorIndex = InFarbe
loZeile = loZeile + 1
Next Dateien
InFarbe = InFarbe + 1
If InFarbe > 56 Then InFarbe = 2
End If
Next
End With
Range("B2:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).Copy
Range("B2").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
End Sub
Gruß Hajo
das ist wohl untergegangen.
Option Explicit
Sub daten_uebernehmen()
Dim Dateien As Integer
Dim loZeile As Long
' Dim strPfad As String
Dim StOrdner
Dim Lol As Long
Dim Datei As String
Dim InFarbe As Integer
InFarbe = 2
StOrdner = Array("C:\Eigene Dateien\Dienstreisen", "C:\Eigene Dateien")
'For Lol = 0 To 1
' MsgBox StOrdner(Lol)
' MsgBox UBound(StOrdner)
'Next Lol
loZeile = 2
' strPfad = "K:\Grafik" '
Application.DisplayAlerts = False
With Application.FileSearch
Dim StAktuell As String
'For Each StAktuell In StOrdner()
For Lol = 0 To UBound(StOrdner)
.NewSearch
.LookIn = StOrdner(Lol)
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
Datei = Mid(.FoundFiles(Dateien), Len(.LookIn) + 2, Len(.FoundFiles(Dateien)))
Cells(loZeile, 1) = Datei
Cells(loZeile, 1).Hyperlinks.Add Anchor:=Cells(loZeile, 1), Address:=StOrdner(Lol) & "\" & Datei, TextToDisplay:=Datei
Cells(loZeile, 2).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!D2"
Cells(loZeile, 3).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H13"
Cells(loZeile, 4).FormulaLocal = "='" & StOrdner(Lol) & "\" & "[" & Datei & "]Tabelle1'!H14"
Range(Cells(loZeile, 1), Cells(loZeile, 4)).Interior.ColorIndex = InFarbe
loZeile = loZeile + 1
Next Dateien
InFarbe = InFarbe + 1
If InFarbe > 56 Then InFarbe = 2
End If
Next
End With
Range("B2:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).Copy
Range("B2").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
End Sub
Gruß Hajo
Antwort 6 von Sp|n.aT
Hi Hajo,
jetzt stop das Makro in der Mitte. Folgende Fehlermeldung habe ich im Visual Basic gefunden
Sub Main()
On Error Resume Next
'' Don't need to call ShutdownDistMon explicitly, because
'' the DLL has already gotten a call to DLLMain with
'' DLL_PROCESS_DETACH, has done the shutdown, and has, in fact,
'' been unloaded from memory
''' ShutdownDistMon
End Sub
Lg Martin
jetzt stop das Makro in der Mitte. Folgende Fehlermeldung habe ich im Visual Basic gefunden
Sub Main()
On Error Resume Next
'' Don't need to call ShutdownDistMon explicitly, because
'' the DLL has already gotten a call to DLLMain with
'' DLL_PROCESS_DETACH, has done the shutdown, and has, in fact,
'' been unloaded from memory
''' ShutdownDistMon
End Sub
Lg Martin
Antwort 7 von Hajo_Zi
Hallo Martin,
bei mir lief das Makro durch, über 2 Verzeichnisse.
Wieviele sind es bei Dir?
In welcher Zeile Stopt das Makro?
Welchen Wert haben die Variablen in der Zeile?
Gruß Hajo
bei mir lief das Makro durch, über 2 Verzeichnisse.
Wieviele sind es bei Dir?
In welcher Zeile Stopt das Makro?
Welchen Wert haben die Variablen in der Zeile?
Gruß Hajo
Antwort 8 von Sp|n.aT
He Hajo,
beim dritten Anlauf hats dann funktioniert. Pcs sind wie Frauen die haben alle ihr Fehler *g*
Die zwei verschieden Ordner sind weiß und schwarz
PERFEKT
wie kann ich diese Farben noch ändern ???
Lg Martin
THX fürs Makro Weltklasse
beim dritten Anlauf hats dann funktioniert. Pcs sind wie Frauen die haben alle ihr Fehler *g*
Die zwei verschieden Ordner sind weiß und schwarz
PERFEKT
wie kann ich diese Farben noch ändern ???
Lg Martin
THX fürs Makro Weltklasse
Antwort 9 von Hajo_Zi
Hallo Martin,
warum Weis und schwarz. Ich hatte es getestet und der erste war weiß und der zweite rot und der nächste hätte wieder eine andere Farbe bis zum Index 56 und dann wieder von vorne.
Am Anfang des Codes steht InFarbe = 2 damit wird die erste Farbe festgelegt. Schaue mal in die Hilfe unter colorindex da sind die Index Nummern.
Gruß Hajo
warum Weis und schwarz. Ich hatte es getestet und der erste war weiß und der zweite rot und der nächste hätte wieder eine andere Farbe bis zum Index 56 und dann wieder von vorne.
Am Anfang des Codes steht InFarbe = 2 damit wird die erste Farbe festgelegt. Schaue mal in die Hilfe unter colorindex da sind die Index Nummern.
Gruß Hajo
Antwort 10 von Sp|n.aT
Guten Morgen Hajo,
habs heut morgen noch mal probiert. Hat perfekt geklappt !!!!
Auch das mit den Farben und so !!!!
Danke für deine schnelle und freundliche Hilfe
lg aus Österreich
Matrin
habs heut morgen noch mal probiert. Hat perfekt geklappt !!!!
Auch das mit den Farben und so !!!!
Danke für deine schnelle und freundliche Hilfe
lg aus Österreich
Matrin