Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1700to1704
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Zelle suchen und Wert ausgeben / Extern Quell

VBA Zelle suchen und Wert ausgeben / Extern Quell
10.07.2019 14:22:07
Marcel
Hallo zusammen,
ich stehe mal wieder vor einem größerem Problem. Ich habe ca. 300 Excel Mappen wo automatisiert nach einem einheitlichen Begriff "Buchung XXX" in einer Spalte gesucht werden soll und dieser Wert daneben in einer neuen Excel Mappe ausgegeben werden soll, zusammen mit den Zellen "J3" und "J4".
Mit einer einzigen Excel Mappe, bekomme ich dies wie folgt hin:
Sub suchen()
Dim strString As String, rngCell As Range
strString = "Buchung XXX"
Set rngCell = Columns(6).Find(strString, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not rngCell Is Nothing Then
rngCell.Offset(0, 4).Resize(1, 1).Copy
Worksheets("NEU").Cells(1, 3).PasteSpecial xlValues
Range("J3").Copy
Worksheets("NEU").Cells(1, 1).PasteSpecial xlValues
Range("J4").Copy
Worksheets("NEU").Cells(1, 2).PasteSpecial xlValues
'MsgBox rngCell.Address 'Ausgabe als Textbox
Else
MsgBox "FEHLER"
End If
End Sub
Jetzt möchte ich dies jedoch automatisiert über die besagten 300 Tabellenblätter anwenden, welche sich alle in einem einzelnen Ordner befinden. Es soll sich daraus eine neue Excel Mappe generieren mit den zusammengetragenen o.g. Werten.
Vielen Dank für eure Unterstützung.
LG Marcel

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: als Ansatz
10.07.2019 14:40:33
Fennek
Hallo,
die Frage wird sehr oft gestellt, scheint aber schwer zu googlen zu sein.

sub Alle_lesen()
dim WS as worksheet:set WS = activesheet
dim WB as Workbook
Pfad = "c:\temp\" '>>
f = dir(Pfad & "*.xlsx")
do while f  ""
set WB = Workbooks.Open(Pfad & f)
'hier dein Code mit WB.Sheets(1).
Wb.close 0
f = dir
loop
end sub
mfg
(ungeprüft)
AW: als Ansatz
10.07.2019 14:51:51
Marcel
Hallo,
vielen Dank!
Was ist mit "WB.Sheets(1)" gemeint?
Wie füge ich meinen Code hier richtig ein?
Besten Dank!
LG
Marcel
AW: als Ansatz
10.07.2019 15:05:10
Marcel
Hallo,
habe es kurz hinbekommen, jedoch wird der ausgelesene Wert immer wieder mit den neuen Werten überschrieben. Wie bekomme ich es hin, dass er im Sheet immer eine neue Zeile nimmt?
BESTEN DANK!
LG Marcel

Sub Alle_lesen()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim WB As Workbook
Dim Pfad        As String
Dim f        As String
Pfad = "C:\Users\xxx\Desktop\Test\" '>>
f = Dir(Pfad & "*.xlsx")
Do While f  ""
Set WB = Workbooks.Open(Pfad & f)
'hier dein Code mit WB.Sheets(1). Dim strString As String, rngCell As Range
Dim strString As String, rngCell As Range
strString = "XXX"
Set rngCell = Columns(6).Find(strString, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not rngCell Is Nothing Then
rngCell.Offset(0, 4).Resize(1, 1).Copy
Worksheets("Tabelle1").Cells(1, 3).PasteSpecial xlValues
Range("J3").Copy
Worksheets("Tabelle1").Cells(1, 1).PasteSpecial xlValues
Range("J4").Copy
Worksheets("Tabelle1").Cells(1, 2).PasteSpecial xlValues
'MsgBox rngCell.Address 'Ausgabe als Textbox
Else
MsgBox "FEHLER"
End If
WB.Close 0
f = Dir
Loop
End Sub

Anzeige
AW: als Ansatz
10.07.2019 15:11:52
Marcel
Hallo,
habe es kurz hinbekommen, jedoch wird der ausgelesene Wert immer wieder mit den neuen Werten überschrieben. Wie bekomme ich es hin, dass er im Sheet immer eine neue Zeile nimmt?
BESTEN DANK!
LG Marcel
Sub Alle_lesen()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim WB As Workbook
Dim Pfad        As String
Dim f        As String
Pfad = "C:\Users\xxx\Desktop\Test\" '>>
f = Dir(Pfad & "*.xlsx")
Do While f  ""
Set WB = Workbooks.Open(Pfad & f)
'hier dein Code mit WB.Sheets(1). Dim strString As String, rngCell As Range
Dim strString As String, rngCell As Range
strString = "XXX"
Set rngCell = Columns(6).Find(strString, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not rngCell Is Nothing Then
rngCell.Offset(0, 4).Resize(1, 1).Copy
Worksheets("Tabelle1").Cells(1, 3).PasteSpecial xlValues
Range("J3").Copy
Worksheets("Tabelle1").Cells(1, 1).PasteSpecial xlValues
Range("J4").Copy
Worksheets("Tabelle1").Cells(1, 2).PasteSpecial xlValues
'MsgBox rngCell.Address 'Ausgabe als Textbox
Else
MsgBox "FEHLER"
End If
WB.Close 0
f = Dir
Loop
End Sub

Anzeige
AW: als Ansatz
10.07.2019 15:44:21
UweD
Hallo
du musst die Zielzeile immer erhöhen.
so...
Sub Alle_lesen()
    Dim WS As Worksheet: Set WS = ActiveWorkbook.ActiveSheet
    Dim WB As Workbook
    Dim Pfad As String
    Dim f As String
    Dim Z As Integer
    
    Pfad = "C:\Users\xxx\Desktop\Test\" '<<< anpassen >>> 
    f = Dir(Pfad & "*.xlsx")
    
    Do While f <> ""
    
        Set WB = Workbooks.Open(Pfad & f)
              'hier dein Code mit WB.Sheets(1). 
        Dim strString As String, rngCell As Range
       
        strString = "XXX"
        Set rngCell = WB.Columns(6).Find(strString, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True)
        If Not rngCell Is Nothing Then
            Z = Z + 1
            WS.Cells(Z, 3).Value = rngCell.Offset(0, 4).Resize(1, 1).Value
            WS.Cells(Z, 1).Value = WB.Range("J3").Value
            
            WS.Cells(Z, 2).Value = WB.Range("J4")
            
            'MsgBox rngCell.Address 'Ausgabe als Textbox 
        Else
            MsgBox "FEHLER"
        End If
           
        WB.Close 0
    
        f = Dir
    Loop
 End Sub

LG UweD
Anzeige
AW: als Ansatz
10.07.2019 15:51:07
UweD
Fennek hat es natürlich richtig gemacht.
Bei mir fehlt das .Sheets(1) nach dem WB
LG UweD
AW: Blindflug!
10.07.2019 15:45:28
Fennek
so ähnlich stelle ich es mir vor:

const iSuch as string = "Buchung XXX"
Sub Alle_lesen()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim WB As Workbook
rr = 1
Pfad = "C:\Users\xxx\Desktop\Test\" '>>
f = Dir(Pfad & "*.xlsx")
Do While f  ""
rr = rr +1
Set WB = Workbooks.Open(Pfad & f)
'hier dein Code mit WB.Sheets(1). Dim strString As String, rngCell As Range
Dim strString As String, rngCell As Range
Set rngCell = WB.Sheets(1).Columns(6).Find(iSuch, lookat:=xlWhole, LookIn:=xlValues, MatchCase: _
=True)
If Not rngCell Is Nothing Then
WS.cells(rr,1) = rngCell.Offset(0, 4)
WS.cells(rr,2) = WB.Sheets(1).Range("J3")
WS.cells(rr,3) = WB.sheets(1).Range("J4")
WB.Close 0
f = Dir
Loop
End Sub
mfg
Anzeige
AW: Blindflug!
10.07.2019 16:10:52
Marcel
Vielen Dank!
Da kommt leider der Fehlercode "Loop ohne Do" ?
AW: Blindflug!
10.07.2019 16:21:50
UweD
Da fehlt ein end if
..
WB.Close 0
End If
..
AW: Blindflug!
11.07.2019 11:53:38
Marcel
Hallo,
vielen Dank, klappt super!
Jetzt habe ich nur noch ein kleines Problem. Ich möchte eine weitere Zelle suchen und diesen Wert 9 Zellen daneben ausgeben. Wie kann ich folgenden Code nochmals einbinden?
Set rngCell = WB.Sheets(1).Columns(6).Find(iSuch, lookat:=xlWhole, LookIn:=xlValues, MatchCase: _
=True)
If Not rngCell Is Nothing Then
WS.cells(rr,1) = rngCell.Offset(0, 9)
Zudem müsste oben die Variabel definiert werden?
const iSuch as string = "Buchung YYY"
Herzlichen Dank!
LG Marcel
Anzeige
AW: Blindflug!
12.07.2019 19:37:01
Piet
Hallo Marcel
probier es bitte mal mit meinem geaenderten Code. Ohne Garantie das es klappt.
Für den zwiten Suchlauf mit "rngCellJ" musst du bitte die Zellangabe für Quelle und Ziel noch korrigieren. Ich habs nur kopiert!
WS.Cells(rr, 2) = WB.Sheets(1).Range("J3")

mfg Piet
   Const iSuch As String = "Buchung XXX"
Const jSuch As String = "Buchung YYY"
Sub Alle_lesen()
Dim strString As String, rngCell As Range
Dim WB As Workbook, rngCellJ As Range
Dim WS As Worksheet: Set WS = ActiveSheet
rr = 1
Pfad = "C:\Users\xxx\Desktop\Test\" '>>
f = Dir(Pfad & "*.xlsx")
Do While f  ""
rr = rr + 1
Set WB = Workbooks.Open(Pfad & f)
'hier dein Code mit WB.Sheets(1). Dim strString As String, rngCell As Range
Set rngCell = WB.Sheets(1).Columns(6).Find(iSuch, lookat:=xlWhole, LookIn:=xlValues,  _
MatchCase:=True)
Set rngCellJ = WB.Sheets(1).Columns(6).Find(jSuch, lookat:=xlWhole, LookIn:=xlValues,  _
MatchCase:=True)
If Not rngCell Is Nothing Then
WS.Cells(rr, 1) = rngCell.Offset(0, 4)
WS.Cells(rr, 2) = WB.Sheets(1).Range("J3")
WS.Cells(rr, 3) = WB.Sheets(1).Range("J4")
End If
If Not rngCellJ Is Nothing Then
WS.Cells(rr, 1) = rngCellJ.Offset(0, 4)
WS.Cells(rr, 2) = WB.Sheets(1).Range("J3")
WS.Cells(rr, 3) = WB.Sheets(1).Range("J4")
End If
WB.Close 0
f = Dir
Loop
End Sub

Anzeige
AW: Blindflug!
13.07.2019 13:08:43
Marcel
Vielen lieben Dank, es klappt super, und sehr schnell - genau das was ich gebraucht habe!
Bekommt man es irgendwie hin, dass noch ein Hyperlink zur Excel-Datei automatisiert erstellt wird, in Spalte 1?
Habe leider nichts passendes gefunden was ich in den bestehenden Code einbinden kann,...
LG Marcel

349 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige