AW: VBA code gesucht .
04.08.2014 09:47:49
fcs
Hallo Christian,
hier 2 Makros.
eines überträgt alle Werte ungleich "", das 2. nach in einer Inputbox vorgegebenem Wert.
Gruß
Franz
Sub SuchenKopieren()
'gesuchte Werte finden und Werte in Zeilen übertragen
Dim wksQ As Worksheet, wksCtrl As Worksheet
Dim ZeileCtrl As Long, intSheet As Integer
Dim rngSuche As Range, varSuche
Dim strAdr_1 As String
Start:
varSuche = InputBox("Suchbegriff:", "Suche in Blättern - kopieren")
If varSuche = "" Then Exit Sub
Set wksCtrl = ActiveWorkbook.Sheets("Control")
With wksCtrl
ZeileCtrl = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
For intSheet = 2 To 10 Step 2
Set wksQ = ActiveWorkbook.Sheets(intSheet)
strAdr_1 = ""
With wksQ
Set rngSuche = .Range("D4:D400").Find(What:=varSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not rngSuche Is Nothing Then
strAdr_1 = rngSuche.Address
Do
ZeileCtrl = ZeileCtrl + 1
wksCtrl.Cells(ZeileCtrl, 1).Value = .Cells(rngSuche.Row, 1).Value
wksCtrl.Cells(ZeileCtrl, 2).Value = .Cells(rngSuche.Row, 4).Value
wksCtrl.Cells(ZeileCtrl, 3).Value = .Cells(rngSuche.Row, 5).Value
Set rngSuche = .Range("D4:D400").FindNext(After:=rngSuche)
Loop Until rngSuche.Address = strAdr_1
End If
End With
Next intSheet
If MsgBox("Weiteren Suchbegriff suchen?", vbQuestion + vbOKCancel, _
"Suche in Blättern - kopieren") = vbOK Then GoTo Start
End Sub
Sub AlleWerteSuchenKopieren()
'Alle Werte "" finden und Werte in Zeilen übertragen
Dim wksQ As Worksheet, wksCtrl As Worksheet
Dim ZeileCtrl As Long, intSheet As Integer
Dim rngSuche As Range, varSuche
Set wksCtrl = ActiveWorkbook.Sheets("Control")
With wksCtrl
ZeileCtrl = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
For intSheet = 2 To 10 Step 2
Set wksQ = ActiveWorkbook.Sheets(intSheet)
With wksQ
For Each rngSuche In .Range("D4:D400")
If rngSuche.Value "" Then
ZeileCtrl = ZeileCtrl + 1
wksCtrl.Cells(ZeileCtrl, 1).Value = .Cells(rngSuche.Row, 1).Value
wksCtrl.Cells(ZeileCtrl, 2).Value = .Cells(rngSuche.Row, 4).Value
wksCtrl.Cells(ZeileCtrl, 3).Value = .Cells(rngSuche.Row, 5).Value
End If
Next rngSuche
End With
Next intSheet
End Sub