Zellen suchen und kopieren

Sub Macro1() ' Macro1 Macro Range("P2").Select Selection.Copy Windows("Mobiltelefonliste_092014_NEU.xlsx").Activate Columns("P:P").Select Selection.Find(What:="491713015039", After:=ActiveCell, LookIn:= _ xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _ xlNext, MatchCase:=False, SearchFormat:=False).Activate Range("E82:O82").Select Range("O82").Activate Application.CutCopyMode = False Selection.Copy Windows("Gassco Vertragsübersich - Copy.xls").Activate Range("E2").Select ActiveSheet.Paste End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo York,
hier ein entsprechendes Makro.
Du kannst in Spalte P eine oder mehrere Zellen selektieren.
Das Makro sucht dann in einer Schleife nach alle Werte und kopiert für die gefundenen Nummern die Daten jeweils nach Spalte E in der Zeile.
Gruß
Franz

Sub Suchen_Mobil_Telefondaten()
Dim varSuchwert, rngSuche As Range
Dim rngFinden As Range, rngCopy As Range, rngZiel As Range
Dim wkbQuelle As Workbook, wksQuelle As Worksheet
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim strMsgTitle As String, strMsgPrompt2 As String, strQuelle As String
strMsgTitle = "Suchen neue Mobil-Telefonnummer"
strMsgPrompt2 = "(Wiederholen nur sinnvoll wenn mehrere Zellen selektiert wurden)"
strQuelle = "Mobiltelefonliste_092014_NEU.xlsx" 'Dateiname der Quelldatei/zu durchsuchenden  _
Datei
On Error GoTo Fehler
Set wkbZiel = ActiveWorkbook 'Gassco Vertragsübersich - Copy.xls
Set wksZiel = ActiveSheet
Set wkbQuelle = Workbooks(strQuelle)
Set wksQuelle = wkbQuelle.Worksheets(1) 'Index-Nummer ggf. anpassen
For Each rngSuche In Selection.Cells 'Selection = 1 Zelle oder mehrere Zellen in Spalte P
varSuchwert = rngSuche.Value
If IsEmpty(varSuchwert) Then
If MsgBox("Zelle " & rngSuche.Address & " enthält keinen Wert" & vbLf _
& strMsgPrompt2, _
vbRetryCancel, strMsgTitle) = vbCancel Then
GoTo Fehler
End If
Else
Set rngFinden = wksQuelle.Columns("P:P").Find(What:=varSuchwert, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
If rngFinden Is Nothing Then
If MsgBox("Nummer """ & varSuchwert & """ in [" & wkbQuelle.Name & "]" _
& wksQuelle.Name & "!P:P"" nicht gefunden" & vbLf _
& strMsgPrompt2, _
vbRetryCancel, strMsgTitle) = vbCancel Then Exit For
Else
'zu kopierenden Zellbereich setzen
With wksQuelle
Set rngCopy = .Range(.Cells(rngFinden.Row, 5), .Cells(rngFinden.Row, 15))
End With
'Zielzelle setzen
Set rngZiel = wksZiel.Cells(rngSuche.Row, 5)
'Daten kopieren
rngCopy.Copy Destination:=rngZiel
Application.CutCopyMode = False
End If
End If
ResumeNext:
Next rngSuche
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 9 'Wert in indexliste nicht gefunden - Arbeitsmappe
MsgBox "Datei """ & strQuelle & """ ist noch nicht geöffnet!", _
vbOKOnly, strMsgTitle
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly, strMsgTitle
End Select
End With
End Sub

If rngFinden Is Nothing Then ' If MsgBox("Nummer """ & varSuchwert & """ in [" & wkbQuelle.Name & "]" _ & wksQuelle.Name & "!P:P"" nicht gefunden" & vbLf _ & strMsgPrompt2, _ vbRetryCancel, strMsgTitle) = vbCancel Then Exit For 'Daten in Spalten E:O in Zeile in Zieltabelle löschen With wksZiel .Range(.Cells(rngSuche.Row, 5), .Cells(rngSuche.Row, 15)).ClearContents End With Else

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen suchen und kopieren

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread