Herbers Excel/VBA-Archiv
| Informationen und Beispiele zum Thema MsgBox | |
|---|---|
 Screenshot zu MsgBox |
MsgBox-Seite mit Beispielarbeitsmappe aufrufen |
| Informationen und Beispiele zum Thema CommandButton | |
|---|---|
 Screenshot zu CommandButton |
CommandButton-Seite mit Beispielarbeitsmappe aufrufen |
| Informationen und Beispiele zum Thema Image | |
|---|---|
 Screenshot zu Image |
Image-Seite mit Beispielarbeitsmappe aufrufen |
In Abhängigkeit eines Suchkriteriums kopieren | Herbers Excel-Forum
- In Abhängigkeit eines Suchkriteriums kopieren von edie vom 16.01.2010 17:59:30
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 18:01:41
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 18:15:27
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 18:20:09
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 18:24:28
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 18:39:49
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 19:10:36
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 19:20:31
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 19:45:22
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 19:54:16
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 20:18:42
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 20:30:33
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 20:35:27
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 20:44:44
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 20:51:22
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 20:54:18
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 20:51:22
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 20:44:44
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 20:35:27
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 20:30:33
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 20:18:42
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 19:54:16
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 19:45:22
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 19:20:31
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 19:10:36
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 18:39:49
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 18:24:28
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von Josef Ehrensberger am 16.01.2010 18:20:09
- AW: In Abhängigkeit eines Suchkriteriums kopieren - von edie am 16.01.2010 18:15:27
Betrifft: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 17:59:30
Hallo zusammen,
habe weit über 500 Arbeitsmappen in einem Ordner und würde gerne, nach dem in der ComboBox ausgewählten Suchkriterium, in dem Ordner gespeicherten Arbeitsmappen durchsuchen. Aus den Dateien mit dem gefundenen Suchkriterium soll der Bereich F6:M10 in die aktive Tabelle ab der Ziele A5 untereinander kopieren werden.
Das Suchkriterium steht in allen Arbeitsmappen in der Tabelle "Rohdaten" in Zelle C6.
Ich habe bereits in der Recherche gesucht und das nachfolgende Makro gefunden.
Leider, mit der ComboBox und Suchkriterium auswählen, haperte es bei mir.
'StandardModule: basMain
Sub DatenImport()
Dim arr As Variant
Dim iCounter As Integer, iRow As Integer
Dim sPath As String
Application.ScreenUpdating = False
sPath = GetDirectory( _
"Bitte Pfad der Quelldateien auswählen:")
If sPath = "" Then Exit Sub
arr = FileArray(sPath, "*.xls")
iRow = 5
For iCounter = 1 To UBound(arr)
Workbooks.Open sPath & "\" & arr(iCounter)
Range("F6:M10").Copy _
ThisWorkbook.ActiveSheet.Cells(iRow, 1)
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 10
Next iCounter
Application.ScreenUpdating = True
End Sub
''Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg As String) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Function FileArray(strPath As String, strPattern As String)
Dim arrDateien()
Dim intCounter As Integer
Dim strDatei As String
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strDatei = Dir(strPath & strPattern)
Do While strDatei <> ""
intCounter = intCounter + 1
ReDim Preserve arrDateien(1 To intCounter)
arrDateien(intCounter) = strDatei
strDatei = Dir()
Loop
FileArray = arrDateien
End Function
Würde mich sehr freuen, wenn jemand helfen könnte. Danke schon jetzt.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 18:01:41
Hallo Edie,
wo steht das Suchkriterium?
Gruß Sepp
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 18:15:27
Hallo Sepp,
das Suchkriterium steht in allen Arbeitsmappen in der Tabelle "Rohdaten" in Zelle C6. Aufbau
aller Dateien ist gleich.
In der zusammenführenden Arbeitsmappe hätte ich gerne das Suchkriterim duch eine ComboBox vorgegebe.
Vielen Dank im Voraus.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 18:20:09
Hallo Edie,
ich meine ja das von die Ausgewählte Suchkriterium!
Combobox auf der Tabelle?
ComboBox aus den Steuerelementen oder aus Formular?
Gruß Sepp
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 18:24:28
Hallo Sepp,
meine Schuld, ja aus einer ComboBox der UserForm.
Veilen Dank im Voraus.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 18:39:49
Hallo Edie,
in ein Allgemeines Modul.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub ImportData(strSearch As String)
Dim objWB As Workbook
Dim strTab As String, strDir As String, strFile As String
Dim lngRow As Long, vntRet As Variant
On Error GoTo ErrExit
GMS
strTab = "Rohdaten"
strDir = fncBrowseForFolder
With ActiveSheet
If strSearch <> "" Then
lngRow = 5
If strDir <> "" Then
strDir = strDir & "\"
strFile = Dir(strDir & "*.xls*", vbNormal)
Do While strFile <> ""
vntRet = GetValue(strDir, strFile, strTab, "C6")
If Not IsError(vntRet) Then
If LCase(vntRet) = LCase(strSearch) Then
Set objWB = Workbooks.Open(strDir & strFile)
objWB.Worksheets(strTab).Range("F6:M10").Copy .Cells(lngRow, 1)
lngRow = lngRow + 1
objWB.Close False
End If
End If
strFile = Dir
Loop
End If
End If
End With
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (ImportData) in Modul Modul2", _
vbExclamation, "Fehler in Modul2 / ImportData"
End With
GMS True
Set objWB = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Private Function GetValue(path As String, file As String, _
sheet As String, ref As String)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
' If Dir(path & file) = "" Then
' GetValue = "File Not Found"
' Exit Function
' End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Aufruf aus dem UF.
Private Sub CommandButton1_Click()
'Name des Buttons und der ComboBox ggf. anpassen!
ImportData ComboBox1.Text
End Sub
Gruß Sepp
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 19:10:36
Hallo Sepp,
eine Fehlermeldung in: ImportData ComboBox1.Text
"unzulässige Verwendung einer Eigenschaft"
Private Sub CommandButton1_Click()
'Name des Buttons und der ComboBox ggf. anpassen!
ImportData ComboBox1.Text
End Sub
1. Frage: Das nachfolgende Marko in Teilen auskommentiert, ist es so Okay?
Private Function GetValue(path As String, file As String, _
sheet As String, ref As String)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
2. Frage: Ich starte meine UserForm in der ComboBox wähle ich das Suchkriterium und bestätige
mit einem Button. Aber wann wird der Ordner mit den Arbeitsmappen gewählt?
3. Frage: Soll das UserForm ImportData heisen?
Vielen Dank für die Hilfe.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 19:20:31
Hallo Edie,
das steht doch klar ersichtlich "'Name des Buttons und der ComboBox ggf. anpassen!"
Frage 1: Ja, lass die Auskommentierung so wie sie ist!
Frage 2: Der Dialog kommt, sobald du den Button klickst, vorausgesetz du rufst im _Click - Event das Makro "ImportData()" auf (siehe Frage 3).
Frage 3: Nein, das soll "ImportData wieimmerdeinecomboboxauchheißenmag.Text" heißen.
Wenn du nicht klar kommst, dann lade die Datei inkl. UF hoch.
Gruß Sepp
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 19:45:22
Hallo Sepp,
es funktioniert soweit, aber es wird immer nur eine Datei mit dem Suchkriterium kopiert.
Es sollten ja alle Dateien durchsucht werden und der Bereich F6:M10 untereinander kopiert
werden in der Datei "Zusammenfassung".
Heir mein Beispiel: https://www.herber.de/bbs/user/67263.zip
Vielen, vielen Dank im Voraus für die Hilfe.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 19:54:16
Hallo Sepp,
habe vergessen das Passwort löschen.
Neue Versuch:
https://www.herber.de/bbs/user/67264.zip
Vielen Dank.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 20:18:42
Hallo Eddie,
ich sagte doch, "lass die Auskommentierung so wie sie ist"!
Ich hebe diesen Codeteil jetzt ganz entfernt.
https://www.herber.de/bbs/user/67265.xls
Gruß Sepp
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 20:30:33
Hallo Sepp,
bin am verzweifeln, habe Deine Datei heruntergeladen, aber immer noch wird nur eine
Datei ausgelesen.
Schade, schade was mache ich nur falsch.
Vielen Dank für Deine Geduld.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 20:35:27
Hallo Sepp,
vielleicht fehlen irgendwelche Verweise?
Vielen Dank und Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 20:44:44
Hallo Edie,
fehlende Verweise sind sicher nicht schuld.
Bei mir werden die Daten tatelos importiert.
Gruß Sepp
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: edie
Geschrieben am: 16.01.2010 20:51:22
Hallo Sepp,
muss voll die Idee verwerfen, schade.
Vielen herzlichen Dank und einen schönen Abend noch.
Grüße
Betrifft: AW: In Abhängigkeit eines Suchkriteriums kopieren
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 20:54:18
Hallo Edie,
warum aufgeben?
Kommentiere am Anfang der Prozedur "importData" mal die Zeilen
On Error GoTo ErrExit
GMS
und am Ende die Zeile
GMS True
aus und lass den Code dann laufen.
Welche Fhlermeldung erscheint?
Gruß Sepp
Betrifft: Hurra
von: edie
Geschrieben am: 16.01.2010 21:04:21
Hallo Sepp,
hurra, Mensch Mayer es funktioniert! Mit Mayer meinte ich mich.
Bin Dir vom herzen dankbar.
Grüße
Betrifft: AW: Hurra
von: Josef Ehrensberger
Geschrieben am: 16.01.2010 21:46:11
Hallo Edie,
läuft es nachdem du die Codeteile auskommentiert hast, oder wie?
Das währe nämlich nicht so gut.
Gruß Sepp
Betrifft: AW: Hurra
von: edie
Geschrieben am: 17.01.2010 17:54:00
Hallo Sepp,
habe auskommentiert und es funktioniert.
Aber das Wichtige ist, dass ich die Beispiel-Dateien ersetzt habe,
vielleicht lag es an den Dateien?
Sollte ich trotzdem den auskommentierte Bereich wieder zurück hohlen?
Vielen Dank und Grüße
Beiträge aus den Excel-Beispielen zum Thema "In Abhängigkeit eines Suchkriteriums kopieren"