Gruppen
- Top Gruppen
- Betriebsysteme
- Windows classik
- Linux
- BS-Sonstige
- Software
- Datenbanken
- Bildbearbeitung
- Audio/mp3/Video
- Security/Viren
- SW-Sonstige
- Hardware
- Mainboard/CPU
- Grafikkarten
- Peripherie
- Laptop/Notebook
- HW-Sonstiges
- Netzwerk
- Telefon,ISDN,Modem
- W-Lan
- NW-Sonstiges
- Programmierung
- PHP,ASP,Perl...
- Java,C++...
- Webseiten/HTML
- Sonstiges
- PC-Sonstiges
- Plauderecke
- SN Intern
- Test
/ Forum / Tabellenkalkulation
Tabellenkalkulation
Fragevon Sp|n.aT vom 19.06.2019, 06:27 Options
Verbessern eines Makros
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
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 vom 19.06.2019, 07:00 Options
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 vom 19.06.2019, 08:09 Options
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 vom 19.06.2019, 08:22 Options
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 vom 19.06.2019, 10:53 Options
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 vom 19.06.2019, 11:08 Options
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 vom 19.06.2019, 13:51 Options
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 vom 19.06.2019, 13:55 Options
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 vom 19.06.2019, 16:23 Options
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 vom 19.06.2019, 16:28 Options
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 vom 20.06.2019, 08:36 Options
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
Ähnliche Themen
Makros - zweiten Drucker als Symbol in die Symbolleiste einfügen
Mikoop 24.11.2006 - 4092 Hits - 1 Antwort
sprachaufnahme verbessern
buddybear 27.03.2007 - 189 Hits -
was kann ich noch verbessern??
gimpy 30.05.2007 - 99 Hits - 6 Antworten
Deaktivierte Makros in Word
schamanno 05.02.2008 - 152 Hits - 3 Antworten
Ich möchte meine PC Leistung verbessern .Kann man dem Ascentive.com/de/WindowsProbleme vertrauen?
quack 24.05.2008 - 65 Hits - 2 Antworten
Hinweis
Diese Frage ist schon etwas älter, Sie können daher nicht mehr auf sie antworten. Sollte Ihre Frage noch nicht gelöst sein, stellen Sie einfach eine neue Frage im Forum..
Neue Einträge
