Thema: Verbessern eines Makros


Seite durchsuchen:
Home


zurück zur Übersicht

Diskussionsgruppe: Tabellenkalkulation

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

 Von: Sp|n.aT Datum: 19.06.2007, 06:27

alle Antworten zu dieser Frage


Antwort 1 von Hajo_Zi vom 19.06.2007, 07:00
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

Antwort 2 von Sp|n.aT vom 19.06.2007, 08:09
habs mal getestet

Fehlermeldung:
Index ausserhalb des gültigen Bereichs

hab meinen Namen vergessen
sorry

lg Martin
Ps: Thx im voraus

Antwort 3 von Hajo_Zi vom 19.06.2007, 08:22
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

Antwort 4 von Sp|n.aT vom 19.06.2007, 10:53
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

Antwort 5 von Hajo_Zi vom 19.06.2007, 11:08
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

Antwort 6 von Sp|n.aT vom 19.06.2007, 13:51
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

Antwort 7 von Hajo_Zi vom 19.06.2007, 13:55
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

Antwort 8 von Sp|n.aT vom 19.06.2007, 16:23
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

Antwort 9 von Hajo_Zi vom 19.06.2007, 16:28
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

Antworten der Gruppe: Tabellenkalkulation
www.supportnet.de



Office 365 stellt vertraute Microsoft Office-Tools für die Zusammenarbeit und Produktivität über die Cloud bereit. So können alle ganz einfach von nahezu überall zusammenarbeiten und auf E-Mails, Webkonferenzen, Dokumente und Kalender zugreifen.