Microsoft Excel

Herbers Excel/VBA-Archiv

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

VBA code gesucht .

Betrifft: VBA code gesucht . von: Spenski
Geschrieben am: 03.08.2014 22:12:41

Hallo

Suche mal wieder einen code.

durchsuche im sheets(2,4,6,8,10) die Spalte D4-D800 nach einträgen.
gibt es dort einträge soll aus dieser zeile der eintrag der Spalte A , Spalte D und Spalte E in eine Liste im tabellenblatt "Control" kopiert werden. (Ab Zeile 2 wg überschrift)
https://www.herber.de/bbs/user/91867.xlsx

gruß
christian

  

Betrifft: AW: VBA code gesucht . von: Robert
Geschrieben am: 04.08.2014 09:41:42

Hallo Spenski,

sowas?

Option Explicit
Dim i, o As Integer

Sub test()
For i = 2 To 10 Step 2
    For o = 4 To 800
        If Worksheets(i).Cells(o, 4) <> "" Then
        Worksheets(i).Range("A" & o & ",D" & o & ",E" & o).Copy
        Worksheets("Control").Cells(Worksheets("Control").UsedRange.SpecialCells( _
xlCellTypeLastCell).Row + 1, 1).PasteSpecial
        End If
    Next o
Next i
End Sub
viele Grüße
Robert


  

Betrifft: AW: VBA code gesucht . von: fcs
Geschrieben am: 04.08.2014 09:47:49

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



  

Betrifft: AW: VBA code gesucht . von: Spenski
Geschrieben am: 04.08.2014 18:00:46

klappen alle 3 vorschläge wunderbar.. dank euch beiden

gruß
christian