Zellen suchen und kopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Zellen suchen und kopieren
von: York
Geschrieben am: 01.06.2015 08:51:00

Hallo zusammen,
Ich habe folgendes Problem.
Ich habe eine Datenbank A die Daten aus der Datenbank B bekommen soll.
Ich kopiere aus A eine Nummer, suche sie in B und kopiere den Teil den ich brauche und füge ihn bei A wieder ein. Da diese Aufgabe öfter vorkommt, möchte ich mir jetzt ein Makro dazu fertig machen, allerdings habe ich kaum Erfahrungen mit Makros. Ich habe mir ein Makro aufgenommen, damit man mein Problem vielleicht noch besser verstehen kann.
Hier der Quelltext:


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

Bild

Betrifft: AW: Zellen suchen und kopieren
von: York
Geschrieben am: 01.06.2015 09:05:08
Ich habe noch vergessen zu sagen, dass das ganze bei knapp über 160 Einträgen erfolgen soll/muss.

Bild

Betrifft: AW: Zellen suchen und kopieren
von: York
Geschrieben am: 01.06.2015 09:06:45
Ich habe noch vergessen zu sagen, dass das ganze bei knapp über 160 Einträgen erfolgen muss/soll.

Bild

Betrifft: AW: Zellen suchen und kopieren
von: fcs
Geschrieben am: 01.06.2015 12:57:42
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


Bild

Betrifft: AW: Zellen suchen und kopieren
von: York
Geschrieben am: 01.06.2015 13:03:23
Also einzelne Nummern scheinen zu klappen, allerdings arbeitet sich das Makro nicht selbstständig durch alle Nummern durch

Bild

Betrifft: AW: Zellen suchen und kopieren
von: York
Geschrieben am: 01.06.2015 13:22:20
Danke für die schnelle Antwort, soweit funktioniert das auch :) Jetzt muss es nur noch von alleine alle Nummern prüfen und nicht jede einzeln.

Bild

Betrifft: AW: Zellen suchen und kopieren
von: York
Geschrieben am: 01.06.2015 14:16:42
Habe es kapiert, ich muss alle Nummer makieren :D Sorry, ein typischer Montag :D

Bild

Betrifft: AW: Zellen suchen und kopieren
von: York
Geschrieben am: 02.06.2015 08:36:26
Eine Frage hätte ich doch noch und zwar soll der Bereich E bis O gelöscht werden, wenn keine Nummer vorhanden ist. Wie ersetze ich die Fehlermeldung so, dass der gewünschte bereich gelöscht wird?

Bild

Betrifft: AW: Zellen suchen und kopieren
von: fcs
Geschrieben am: 02.06.2015 13:07:29
Hallo York,

      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

Gruß
Franz

Bild

Betrifft: AW: Zellen suchen und kopieren
von: York
Geschrieben am: 02.06.2015 14:32:21
Du bist der Beste!, danke dir :)

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Zellen suchen und kopieren"