Werte in anderer Excel-Tabelle suchen (Kopieren)

Question

Hallo erst ein mal !!!
Ich suche ein Makro womit ich zelleninhale in einer anderen
excel tabelle ( Termiene) suchen kann,diese dan kopieren von spalte x bis x
die werte sollen dann in meiner excel tabelle eingetragen werden in einer bestimmten spalte (zeile).
die excel liste aus der die werte stammen soll danach wieder geschlossen werden.
Danke schon mal für eure hilfe
gruß nero.

Answer 1

hi all ^^

ein ansatz

gruss nighty

ausgehend davon das die gesuchten nummern einmalig vorhanden sind

anpassung des dateinamens,der zu oeffnenden datei

Worksheets(1).Range("A1") dient der eingabe einer zahl.
die dann gesucht wird in einer datei die geoeffnet wird und zur zeit in spalte a die zahl sucht und den danebenliegenden wert bzw spalte b kopiert nach
ThisWorkbook.Worksheets(1).Range("A5")

Option Explicit
Sub DateiLesen()
Dim DateiName As String
Dim Suche As Range
DateiName = "DeinDateiName.xls"
Workbooks.Open Filename:="C:\Temp\" & DateiName
Set Suche = Workbooks(DateiName).Worksheets(1).Range("A1:A" & Workbooks(DateiName).Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find(ThisWorkbook.Worksheets(1).Range("A1"))
If Not Suche Is Nothing Then
ThisWorkbook.Worksheets(1).Range("A5") = Workbooks(DateiName).Worksheets(1).Cells(Suche.Row, Suche.Column + 1)
End If
Workbooks(DateiName).Close
End Sub

Answer 2

hi all ^^

sollten es mehrere zeilen sein
so ware der autofilter eine variante,gefilterte daten kopieren/einfuegen

gruss nighty

Answer 3

Hallo Nero,
konnte mich aus beruflichen Gründen länger nicht melden.

Code in ein Modul der Datei "Werkstatt" einfügen.
Pfad der Terminliste ändern.

Option Explicit
Sub Start()
Application.ScreenUpdating = False
ChDir "C:\Dokumente und Einstellungen\Admin\Desktop"
Workbooks.Open Filename:="C:\Dokumente und Einstellungen\Admin\Desktop\Terminliste.xls"
Workbooks("Terminliste.xls").Sheets("Tabelle1").Activate
Application.Run "Terminliste.xls!Tabelle1.Suchen"
Workbooks("Terminliste.xls").Close
End Sub

Code in das Codefenster der Tabelle1 der Datei "Terminliste" einfügen.

Option Explicit
Sub Suchen()
Application.ScreenUpdating = False
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Sheets("Tabelle1").Range("B5:B" & Range("B1504").End(xlUp).Row)
With rngBer
strSuch = InputBox("Suchen nach:", "Suchen in Spalte: B")
If strSuch = "" Then
Exit Sub
End If
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Eintrag nicht vorhanden"
Else
firstAddress = c.Address
Do
c.Activate
Loop While Not c Is Nothing And c.Address <> firstAddress

Sheets("Tabelle1").Range(ActiveCell.Offset(0, 16), ActiveCell.Offset(0, -1)).Copy Workbooks("Werkstatt.xls").Sheets("Tabelle1").Range("A15")
End If
End With
Workbooks("Terminliste.xls").Close
End Sub

Mustertabellen:
Auch hier Pfadangaben "Terminliste" ändern.
Werkstatt


Terminliste

Gruß
fedjo

Answer 4

Hallo fedjo , danke für deine Hilfe !!!!
habe den code in meinen tabelle kopiert,es klapt auch so weit ganz gut.
auser das er mir einen fehler anzeigt...!

Index außerhalb des gültigen Bereichs (Fehler 9)
bei: Workbooks("Terminliste.xls").Close

Sub Start()
Application.ScreenUpdating = False
ChDir "I:\Terminliste"
Workbooks.Open Filename:="I:\Terminliste\Terminliste_neu.xls"
Workbooks("Terminliste_neu.xls").Sheets("Tabelle1").Activate
Application.Run "Terminliste_neu.xls!Tabelle1.Suchen"
Workbooks("Terminliste_neu.xls").Close
End Sub


Woran kann das wohl liegen...
Danke noch mal !!

Answer 5

Hallo Nero,
Code in der Datei Terminliste ersetzen:
Option Explicit
Sub Suchen()
Application.ScreenUpdating = False
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Sheets("Tabelle1").Range("B5:B" & Range("B1504").End(xlUp).Row)
With rngBer
strSuch = InputBox("Suchen nach:", "Suchen in Spalte: B")
If strSuch = "" Then
Workbooks("Terminliste.xls").Close ' neu eingefügt
Exit Sub
End If
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Eintrag nicht vorhanden"
Else
firstAddress = c.Address
Do
c.Activate
Loop While Not c Is Nothing And c.Address <> firstAddress
Sheets("Tabelle1").Range(ActiveCell.Offset(0, 16), ActiveCell.Offset(0, -1)).Copy Workbooks("Werkstatt.xls").Sheets("Tabelle1").Range("A15")
End If
End With
Workbooks("Terminliste.xls").Close
End Sub

Im Makro Start die Zeile löschen:
Workbooks("Terminliste_neu.xls").Close

Gruß
fedjo

Answer 6

Hallo fedjo !!!
danke noch mal es hat geklaptt super !!!!
eine frage habe ich da noch,ist es möglich die abfrage ob er meine terminliste speichern soll ja/nein weg zulassen ...?
also das er einfach die terminliste schließt ohne speichern...?!
wen nicht ist auch ok
du hast mir schon sehr weiter geholfen !!!!!!!!!!!!!!!
gruß nero

Answer 7

Hallo Nero
beim Makro "Suchen" gleich am Anfang des Codes einfügen:
Application.DisplayAlerts = False

Am Ende des Codes einfügen
Application.DisplayAlerts = True

Alle Meldungen werden dadurch unterdrückt und wieder aktiviert.

Gruß
fedjo

Answer 8

Hallo fedjo,
habe die beiden sachen bei suchen hinzugefügt,
dan sagt mir excel auf einmal wen ich das suchen ausführe,
das excel ein fehler hat und beendet werden muß...?

gruß nero.

Option Explicit
Sub Suchen()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Sheets("Eingabe Termine").Range("B5:B" & Range("B1504").End(xlUp).Row)
With rngBer
strSuch = InputBox("Suchen nach:", "Suchen in Spalte: B")
If strSuch = "" Then
Workbooks("Terminliste_neu.xls").Close ' neu eingefügt
Exit Sub
End If
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Eintrag nicht vorhanden"
Else
firstAddress = c.Address
Do
c.Activate
Loop While Not c Is Nothing And c.Address <> firstAddress
Sheets("Eingabe Termine").Range(ActiveCell.Offset(0, 16), ActiveCell.Offset(0, -1)).Copy Workbooks("Werkstatt.xls").Sheets("Tabelle1").Range("A15")
End If
End With
Workbooks("Terminliste_neu.xls").Close
Application.DisplayAlerts = True
End Sub

Answer 9

Hallo Nero,
welche Excel Version verwendest du?

Gruß
fedjo

Answer 10

Hallo Nero,
versuchs mal so:

Option Explicit
Sub Suchen()
Application.ScreenUpdating = False
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Sheets("Tabelle1").Range("B5:B" & Range("B1504").End(xlUp).Row)
With rngBer
strSuch = InputBox("Suchen nach:", "Suchen in Spalte: B")
If strSuch = "" Then
Workbooks("Terminliste.xls").Close
Exit Sub
End If
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Eintrag nicht vorhanden"
Else
firstAddress = c.Address
Do
c.Activate
Loop While Not c Is Nothing And c.Address <> firstAddress
Sheets("Tabelle1").Range(ActiveCell.Offset(0, 16), ActiveCell.Offset(0, -1)).Copy Workbooks("Werkstatt.xls").Sheets("Tabelle1").Range("A15")
End If
End With
Workbooks("Terminliste.xls").Close SaveChanges:=False
End Sub

Gruß
fedjo