Supportnet Computer
Planet of Tech

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

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

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

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

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

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

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

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

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

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

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: