Werte suchen und def bereich kopieren

Computer: Software & Programmierung Visual Basic
#1

Hallo zusammen,
ich möchte gern Werte aus einer Tabelle (A) in einer anderen Tabelle (B) finden. Wenn in (B) was gefunden wird, dann die ganze Zeile kopieren, bzw. besser einen definierten Bereich der Zeile kopieren in Tabelle (A) hinter die Suchbegriffe
Das hier sind meine Anfänge zu dem Thema. Ich wollte erst mal die „53“ in einer Tabelle finden und dann die entsprechende Zeile unter den Suchbereich kopieren. Das funktioniert nicht. Es gibt aber auf jeden Fall die 53111 in einer Zelle der Tabelle.
Kann mir da jemand weiter helfen, bitte!!!

Danke,Jens

Sub schleife()

'Dim z As range

Zielbook = ActiveWorkbook.Name
Zielsheet = ActiveSheet.Name
s = 53
'Range(„A:open_mouth:“).Select

'Dim bereich As Range

Set bereich = Application.InputBox _
(„Zellbereich der Suchkriterien!“, Type:=8)
Range(bereich.Address).Select

'With Selection
i2 = Range(bereich.Address).CurrentRegion.Rows.Count

For i = 2 To i2

'Set s = .Find(s, LookIn:=xlValues)

If ActiveCell.Value = s _
Or Left(ActiveCell.Value, 2) = s Then
Rows(i).Select

Selection.Copy

Cells(i2 + i, 1).Select
ActiveSheet.Paste
End If
Next i

'End With

'Set bereich = Sheets(Zielsheet).Columns(1).Find(s, LookAt:=xlPart)
'bereich.Select
'Rows(z).Select

'Selection.Copy

End Sub

#2

Hallo,
erstmal empfehle ich immer gern, beim Programmieren auf die Datentypen zu achten, Option Explicit zu verwenden und eine Präfixnotation (str, lng, wkb, sht, rng, …)
Man könnte sonst z.B. meinen „Zielbook“ sei ein Excel.Workbook-Objekt obwohl es nur ein String ist ("=ActiveWorkbook.Name").

Diese Makro sucht jedenfalls alle in shtSource vorkommenden „73“ und kopiert jeweils die ganze Zeile nach shtTarget. (49 Zeilen und 2 Spalten werden hier als Beispiel-Suchbereich angenommen) (Kommt der Wert in mehreren Spalten einer Zeile vor, wird sie trotzdem nur 1 mal kopiert: siehe ‚blnFndInRow‘)
Viel Erfolg noch,
Michael

Option Explicit
Sub subSchleife()
 Dim strSearchFor As String 'str=String
 Dim rngFound As Excel.Range 'rng=Range
 Dim rngTarget As Excel.Range 'rng=Range
 Dim wkb As Excel.Workbook 'wkb=Workbook
 Dim shtSource As Excel.Worksheet 'sht=Worksheet
 Dim shtTarget As Excel.Worksheet 'sht=Worksheet
 Dim lngFndCnt As Long 'FoundCount lng=Long, cnt=Count(Anzahl)
 Dim lngSrcRow As Long 'Row
 Dim lngSrcCol As Long 'Column
 Dim strValChk As String 'Value to check
 Dim blnFndInRow As Boolean 'Found in Row?
 Set wkb = Excel.Workbooks("ExcelTest1.xls")
 Set shtTarget = wkb.Sheets("ZielBlatt")
 Set shtSource = wkb.Sheets("QuellBlatt")
 lngFndCnt = 0
 strSearchFor = "73"
 shtSource.Activate

 For lngSrcRow = 1 To 49
 blnFndInRow = False
 For lngSrcCol = 1 To 2
 Set rngFound = shtSource.Cells(lngSrcRow, lngSrcCol)
 strValChk = rngFound.Text
 If InStr(1, strValChk, strSearchFor) \> 0 Then
 blnFndInRow = True
 Exit For
 End If
 Next lngSrcCol
 If blnFndInRow Then
 lngFndCnt = lngFndCnt + 1
 shtSource.Rows(rngFound.Row).Copy
 With shtTarget
 .Activate
 .Cells(lngFndCnt, 1).Select
 .Paste
 End With
 End If
 Next lngSrcRow
 MsgBox lngFndCnt & " Zeilen gefunden."
End Sub
#3

Hallo zusammen,
danke für das andere Makro, das konnte ich aus zeitmangel nicht austesten, werde das aber demnächst tun.
In der Zwischenzeit habe ich selbst weiter getestet und folgendes entwickelt. Sicher nicht sehr schön, aber es funktioniert fast.

Und zwar klappt es nicht, wenn ich große Datenmengen durchsuche, dann kommt ein Fehler. Laufzeitfehler 91 „Objektvariable oder with-blockvariable nicht festgelegt“

was kann ich tun, damit es funktioniert?

Danke,Jens

Sub wertsuchenzeilekopieren2()

i = 1

Quelle = ActiveWorkbook.Name

msg = MsgBox(„Datei öffnen?“, vbYesNoCancel)

If msg = 2 Then Exit Sub

Application.Dialogs(xlDialogOpen).Show _
„U:“

Quelle2 = ActiveWorkbook.Name

Workbooks.Add
zielbook = ActiveWorkbook.Name
Worksheets(1).Name = („zielsheet“)

For schl = 1 To 6000

Workbooks(Quelle).Activate
s = Cells(schl, 1)

i = i + 1

Workbooks(Quelle2).Activate

'Set bereich = Application.InputBox _
(„Zellbereich der Suchkriterien!“, Type:=8)
'Range(bereich.Address).Select

'For i = 2 To 10
'Rows(i).Select
'wert = Cells(i, z).Value
'Set s = .Find(s, LookIn:=xlValues)

'Set bereich = Application.InputBox
'(„Wählen Sie einen Zellenbereich aus!“, Type:=8)
'Range(bereich.Address).Select

Cells.Find(What:=s, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate

x = ActiveCell.Row

Rows(x).Select
Selection.Copy
'rows(activecell)select

Workbooks(zielbook).Activate
Cells(i, 1).Select
ActiveSheet.Paste

Next schl

'End With

'Set bereich = Sheets(Zielsheet).Columns(1).Find(s, LookAt:=xlPart)
'bereich.Select
'Rows(z).Select

'Selection.Copy

End Sub

#4

weiterentwicklung
nochmals hallo zusammen,

ich habe das prog mal versucht auf meinen Bedingung zu erweitern.
Hat nur fast funktioniert.
wenn der string(?) aus QuellBlatt2 in Quellblatt nicht gefunden wird, dann in der nächsten Zeile im Zielblatt den nicht gefundenen Wert einfügen(damit ich später weiß, welcher nicht gefunden wurde).
Jetzt wird jeder zu suchende Wert in Zielblatt eingefügt und wenn vorhanden auch die Zeile aus dem Quellblatt, wo der String gefunden wurde.
Außerdem möchte ich nur nach kompletten Strings suchen, dh. wenn ich nach 24567-1 suche soll nicht 24567-123 gefunden werden.

Sonst schon mal vielen Dank, das hat mir schon sehr geholfen.

Mit dem Explicit, das hat nicht funktioniert…

Gruß,Jens
Sub subSchleife()

Dim strSearchFor As String 'str=String
Dim rngFound As Excel.Range 'rng=Range
Dim rngTarget As Excel.Range 'rng=Range
Dim wkb As Excel.Workbook 'wkb=Workbook
Dim shtSource As Excel.Worksheet 'sht=Worksheet
Dim shtSource2 As Excel.Worksheet
Dim shtTarget As Excel.Worksheet 'sht=Worksheet
Dim lngFndCnt As Long 'FoundCount lng=Long, cnt=Count(Anzahl)
Dim lngSrcRow As Long 'Row
Dim lngSrcCol As Long 'Column
Dim strValChk As String 'Value to check
Dim blnFndInRow As Boolean 'Found in Row?
Set wkb = Excel.Workbooks(„ExcelTest1.xls“)
Set shtTarget = wkb.Sheets(„ZielBlatt“)
Set shtSource = wkb.Sheets(„QuellBlatt“)
Set shtSource2 = wkb.Sheets(„QuellBlatt2“)
lngFndCnt = 0

For i = 1 To 62

strSearchFor = shtSource2.Cells(i, 1)
shtSource.Activate

For lngSrcRow = 1 To 5000
blnFndInRow = False
For lngSrcCol = 20 To 20
Set rngFound = shtSource.Cells(lngSrcRow, lngSrcCol)
strValChk = rngFound.Text
If InStr(1, strValChk, strSearchFor) > 0 Then
blnFndInRow = True
Exit For
End If
Next lngSrcCol
If blnFndInRow Then
lngFndCnt = lngFndCnt + 1
shtSource.Rows(rngFound.Row).Copy
With shtTarget
.Activate
.Cells(lngFndCnt, 1).Select
.Paste
End With

End If
Next lngSrcRow

If lngFndCnt = lngFndCnt Then
lngFndCnt = lngFndCnt + 1
With shtSource2
.Activate
.Cells(i, 1).Copy
End With
With shtTarget
.Activate
.Cells(lngFndCnt, 1).Select
.Paste
End With

End If
MsgBox lngFndCnt & " Zeilen gefunden."
Next i
End Sub