VBA -Wert suchen-Zeilen aus anderer Mappe einlesen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub CommandButton1_Click() Dim rngZelle As Range Dim strSuchwort As String strSuchwort = ThisWorkbook.Sheets("Tabelle1").Range("B1") For Each rngZelle In Workbooks("Test.xlsx").Worksheets("Tabelle1").Range("A2:A5000") If rngZelle = strSuchwort Then rngZelle.EntireRow.Copy Sheets("Tabelle1").Range("A" & Sheets("Tabelle1").Cells( _ Rows.Count, 1).End(xlUp).Row + 1) End If Next rngZelle End Sub

Hallo Markus,
null problemo, ich mach sowas meistens mit der Find-Methode.
Alternativ könntest Du die Treffer auch in ein Array packen und das Öffnen der Datei bei Bedarf auch noch automatisieren...

Option Explicit

Public Sub prcSuch()
Const SOURCE_NAME As String = "Test.xlsx" 'Quelldatei 
Dim objRange As Range, objUnion As Range
Dim strFirstAddress As String, strName As String
Dim wksSource As Worksheet
Dim lngIndex As Long
With Application
   .ScreenUpdating = False
    On Error Resume Next
    strName = Workbooks(SOURCE_NAME).Name
    If Err Then
      On Error GoTo 0
      MsgBox "Die Datei '" & SOURCE_NAME & "' ist noch nicht geöffnet!", _
         vbExclamation, "Bitte Datei öffnen"
    Else
      On Error GoTo 0
      Set wksSource = Workbooks(SOURCE_NAME).Worksheets("Tabelle1")
      With ThisWorkbook.Worksheets("Tabelle1") 'Zieldatei 
          .Cells(2, .UsedRange.Columns(1).Column).Resize(.UsedRange.Rows.Count - 1, _
            .UsedRange.Columns.Count - 1).ClearContents
          With wksSource.Cells(2, 1).Resize(4999, 1)
              Set objRange = .Find(What:=ThisWorkbook.Worksheets("Tabelle1").Cells(1, 2), _
                 LookIn:=xlValues, LookAt:=xlWhole)
              If Not objRange Is Nothing Then
                  strFirstAddress = objRange.Address
                  Do
                     With wksSource.Cells(objRange.Row, 3)
                         If Not objUnion Is Nothing Then
                           Set objUnion = Union(objUnion, .Resize(1, 10))
                         Else
                           Set objUnion = .Resize(1, 10)
                         End If
                     End With
                     Set objRange = .FindNext(After:=objRange)
                  Loop While Not objRange Is Nothing And objRange.Address <> strFirstAddress
              End If
          End With
          For lngIndex = 1 To objUnion.Areas.Count
             objUnion.Areas(lngIndex).Copy
             .Cells(7 + lngIndex, 2).PasteSpecial xlPasteValues
          Next
      End With
      .CutCopyMode = False
      Set objRange = Nothing
      Set objUnion = Nothing
      Set wksSource = Nothing
    End If
    .ScreenUpdating = True
End With
End Sub



VBA/HTML - CodeConverter für Office-Foren

AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel


Code erstellt und getestet in Office 12

Gruß, Mullit

Option Explicit Private Sub CommandButton1_Click() Call prcSuch End Sub Private Sub prcSuch() Const SOURCE_NAME As String = "Test.xlsx" Dim objRange As Range Dim wksSource As Worksheet, wksTarget As Worksheet Dim strFirstAddress As String, strName As String Dim lngIndex As Long With Application .ScreenUpdating = False On Error Resume Next strName = Workbooks(SOURCE_NAME).Name If Err Then On Error GoTo 0 MsgBox "Die Datei '" & SOURCE_NAME & "' ist noch nicht geöffnet!", _ vbExclamation, "Bitte Datei öffnen" Else On Error GoTo 0 Set wksSource = Workbooks(SOURCE_NAME).Worksheets("Tabelle1") 'Quelldatei Set wksTarget = ThisWorkbook.Worksheets("Tabelle1") 'Zieldatei With wksTarget .Cells(2, .UsedRange.Columns(1).Column).Resize(.UsedRange.Rows.Count - 1, _ .UsedRange.Columns.Count - 1).ClearContents End With With wksSource.Cells(2, 1).Resize(4999, 1) Set objRange = .Find(What:=wksTarget.Cells(1, 2), LookIn:=xlValues, LookAt:=xlWhole) If Not objRange Is Nothing Then strFirstAddress = objRange.Address Do lngIndex = lngIndex + 1 wksSource.Cells(objRange.Row, 3).Resize(1, 10).Copy wksTarget.Cells(7 + lngIndex, 2).PasteSpecial xlPasteValues Set objRange = .FindNext(After:=objRange) Loop While Not objRange Is Nothing And objRange.Address <> strFirstAddress End If End With .CutCopyMode = False Set objRange = Nothing Set wksSource = Nothing Set wksTarget = Nothing End If .ScreenUpdating = True End With End Sub VBA/HTML - CodeConverter für Office-Foren AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann Projektbetreuung durch mumpel Code erstellt und getestet in Office 12

Option Explicit Private Sub CommandButton1_Click() Call prcSuch End Sub Private Sub prcSuch() Const SOURCE_NAME As String = "Test.xlsx" Dim objRange As Range Dim wksSource As Worksheet, wksTarget As Worksheet Dim strFirstAddress As String, strName As String Dim lngIndex As Long With Application .ScreenUpdating = False On Error Resume Next strName = Workbooks(SOURCE_NAME).Name If Err Then On Error GoTo 0 With ThisWorkbook Workbooks.Open .Path & "\" & SOURCE_NAME .Activate End With Else: On Error GoTo 0 End If Set wksSource = Workbooks(SOURCE_NAME).Worksheets("Tabelle1") 'Quelldatei Set wksTarget = ThisWorkbook.Worksheets("Tabelle1") 'Zieldatei With wksTarget .Cells(2, .UsedRange.Columns(1).Column).Resize(.UsedRange.Rows.Count - 1, _ .UsedRange.Columns.Count - 1).ClearContents End With With wksSource.Cells(2, 1).Resize(4999, 1) Set objRange = .Find(What:=wksTarget.Cells(1, 2), LookIn:=xlValues, LookAt:=xlWhole) If Not objRange Is Nothing Then strFirstAddress = objRange.Address Do lngIndex = lngIndex + 1 wksSource.Cells(objRange.Row, 3).Resize(1, 10).Copy wksTarget.Cells(7 + lngIndex, 2).PasteSpecial xlPasteValues Set objRange = .FindNext(After:=objRange) Loop While Not objRange Is Nothing And objRange.Address <> strFirstAddress End If End With .CutCopyMode = False .ScreenUpdating = True End With Set objRange = Nothing Set wksSource = Nothing Set wksTarget = Nothing End Sub VBA/HTML - CodeConverter für Office-Foren AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann Projektbetreuung durch mumpel Code erstellt und getestet in Office 12

Option Explicit Private Sub CommandButton1_Click() Call prcSuch End Sub Private Sub prcSuch() Const SOURCE_NAME As String = "Test.xlsx" Dim objRange As Range Dim wksSource As Worksheet, wksTarget As Worksheet Dim strFirstAddress As String, strName As String Dim lngIndex As Long With Application .ScreenUpdating = False On Error Resume Next strName = Workbooks(SOURCE_NAME).Name If Err Then On Error GoTo 0 With ThisWorkbook Workbooks.Open .Path & "\" & SOURCE_NAME .Activate End With Else: On Error GoTo 0 End If Set wksSource = Workbooks(SOURCE_NAME).Worksheets("Tabelle1") 'Quelldatei Set wksTarget = ThisWorkbook.Worksheets("Tabelle1") 'Zieldatei With wksTarget .Cells(2, .UsedRange.Columns(1).Column).Resize(.UsedRange.Rows.Count - 1, _ .UsedRange.Columns.Count - 1).ClearContents End With With wksSource.Cells(2, 1).Resize(4999, 1) Set objRange = .Find(What:=wksTarget.Cells(1, 2), LookIn:=xlValues, LookAt:=xlWhole) If Not objRange Is Nothing Then strFirstAddress = objRange.Address Do lngIndex = lngIndex + 1 wksTarget.Cells(7 + lngIndex, 2).Resize(1, 10).Value = _ wksSource.Cells(objRange.Row, 3).Resize(1, 10).Value Set objRange = .FindNext(After:=objRange) Loop While Not objRange Is Nothing And objRange.Address <> strFirstAddress End If End With .ScreenUpdating = True End With Set objRange = Nothing Set wksSource = Nothing Set wksTarget = Nothing End Sub VBA/HTML - CodeConverter für Office-Foren AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann Projektbetreuung durch mumpel Code erstellt und getestet in Office 12

Beliebteste Forumthreads (12 Monate)

VBA -Wert suchen-Zeilen aus anderer Mappe einlesen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA -Wert suchen-Zeilen aus anderer Mappe einlesen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread