Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Finden und Kopieren


Betrifft: Finden und Kopieren von: Mark
Geschrieben am: 03.10.2019 14:44:13

Hallo Ihr VBA Bestien,

Ich hab schon einige Probleme gelöst aber komme mit einem Stück nicht weiter. Ich möchte von einer Tabelle (welche ich mit VBA aus dem Netzwerk ziehe) einige Daten suchen und in einer weiteren Tabelle kopieren.

Ich bin schon ziemlich weit aber brauche noch ein wenig Hilfe.
- Ich möchte das Suchen von der Ziel Tabelle nicht von der Suchen&Kopieren Tabelle aus starten

Vielleicht hat jemand eine Idee wie ich den Code ändern muß:


Sub FindAndCopy2c()
   Dim rngSuch As Range, wksDst As Worksheet, wksSrc As Worksheet
   Dim strSuch As String, rngFound As Range
   Dim strFirst As String, FoundAdr As String
   Dim ZeSrc As Integer, ZeDst As Integer, lRow As Long
   Dim i As Integer, ZielOK As Boolean, ZielName As String
   
   ZielName = "Ziel"
   With ThisWorkbook
      For i = 1 To ThisWorkbook.Sheets.Count
         If .Sheets(i).Name = ZielName Then
            ZielOK = True
            Exit For
         End If
      Next i
      If Not ZielOK Then
         .Sheets.Add After:=.Worksheets(Worksheets.Count)
         ActiveSheet.Name = ZielName
      End If
   End With
   
   Set wksSrc = Sheets("Suchen&Kopieren")
   With wksSrc
      lRow = .Cells(Rows.Count, 1).End(xlUp).Row
      Set rngSuch = .Range("B1:B" & lRow)
   End With
   Set wksDst = Sheets(ZielName)
   
   With wksSrc
      If Trim(wksSrc.Range("F4")) = "" Then
         MsgBox "Die Zelle F4 ist leer, darum kann nicht gesucht werden", vbExclamation, " _
Fehler"
         Exit Sub
      End If
      strSuch = .Range("F4")
      .Range("F4").ClearContents
   End With
   
   With rngSuch
      Set rngFound = .Find(what:=strSuch, LookAt:=xlWhole)
      If Not rngFound Is Nothing Then
         strFirst = rngFound.Address
         Do
            FoundAdr = rngFound.Address
            ZeSrc = rngFound.Row
            ZeDst = wksDst.Cells(Rows.Count, 4).End(xlUp).Row + 1
            Range("A" & ZeSrc & ":C" & ZeSrc).Copy wksDst.Cells(ZeDst, 1)
            Set rngFound = .FindNext(rngFound)
         Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
      Else
         MsgBox "Leider wurde  '" & strSuch & "'  nicht gefunden!", vbInformation, "Fehleingabe? _
 _
 _
 _
"
      End If
   End With
End Sub

  

Betrifft: AW: Finden und Kopieren von: ChrisL
Geschrieben am: 03.10.2019 19:10:42

Hi Mark

Set wksSrc = Workbooks("xy.xlsm").Sheets("Suchen&Kopieren")
Ohne explizite Angabe referenzierst du immer auf die aktive Mappe (ActiveWorkbook).

cu
Chris


  

Betrifft: AW: Finden und Kopieren von: ChrisL
Geschrieben am: 03.10.2019 19:13:26

dito hier...

Set wksDst = ThisWorkbook.Sheets(ZielName)



  

Betrifft: AW: Finden und Kopieren von: ChrisL
Geschrieben am: 04.10.2019 13:00:45

Hi

Ich hatte erst interpretiert, dass mehrere Mappen im Spiel sind, aber vermutlich läuft der Prozess innerhalb der gleichen Mappe.

Die Problemursache könnte die fehlende Referenzierung zum Tabellenblatt in folgender Zeile sein:
wksSrc.Range("A" & ZeSrc & ":C" & ZeSrc).Copy

Jedenfalls habe ich dir den Code mal etwas aufgeräumt.

Sub t()
Const strZiel As String = "Ziel"
Dim wksSrc As Worksheet, wksDst As Worksheet, wksTemp As Worksheet
Dim strSuch As String, intCounter As Long

Application.ScreenUpdating = False

' Tabellen festlegen
With ThisWorkbook
    Set wksSrc = .Worksheets("Suchen&Kopieren")
    For Each wksTemp In .Worksheets
        If wksTemp.Name = strZiel Then
            Set wksDst = wksTemp
            Exit For
        End If
    Next wksTemp
    If wksDst Is Nothing Then
        .Sheets.Add After:=.Worksheets(Worksheets.Count)
        Set wksDst = ActiveSheet
        wksDst.Name = strZiel
    End If
End With

With wksSrc
    ' Plausi
    If Trim(.Range("F4")) = "" Then
        MsgBox "Die Zelle F4 ist leer, darum kann nicht gesucht werden", _
            vbExclamation, " Fehler "
        Exit Sub
    End If
    strSuch = .Range("F4")
    If WorksheetFunction.CountIf(.Columns(2), strSuch) = 0 Then
       MsgBox "Leider wurde  '" & strSuch & "'  nicht gefunden!", vbInformation, "Fehleingabe?"
        Exit Sub
    End If
    
    ' Kopieren
    For intCounter = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
        If .Cells(intCounter, 2) = strSuch Then _
            .Range(.Cells(intCounter, 1), .Cells(intCounter, 3)).Copy _
            wksDst.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next intCounter
End With
End Sub

cu
Chris


  

Betrifft: AW: Finden und Kopieren von: ChrisL
Geschrieben am: 04.10.2019 18:46:32

ein letztes Selbstgespräch...

Hier fehlt noch ein Punkt

.Sheets.Add After:=.Worksheets(.Worksheets.Count)


Beiträge aus dem Excel-Forum zum Thema "Finden und Kopieren"