Array

[Gast_1979]

Hallo zusammen,

ich möchte folgendes tun:

wenn unter G5:G10 eine 1 steht, soll der String aus Zelle 4 Stellen weiter links in ein Array gespeichert werden und zum Schluss alle werte in H1 geschrieben werden.

Was passiert: es werden alle Werte gefunden, aber nur der erste in H1 geschrieben.

Was muss ich denn ändern?

Code:

Dim myBedingung As Range
Dim myTreffer As String
Dim myMAGruppe()
Dim myArraySize As Integer

Set myBedingung = Range("G5:G10").Find(what:="1")
   If Not myBedingung Is Nothing Then
       myTreffer = myBedingung.Address
       
       Do
       ReDim Preserve myMAGruppe(2, myArraySize)
       
           If myBedingung.Value = "1" Then
           
               myMAGruppe(0, myArraySize) = myBedingung.Offset(0, -4).Value
               myArraySize = myArraySize + 1
           End If
           
       Set myBedingung = Range("G5:G10").FindNext(myBedingung)
       
     
       Loop While Not myBedingung Is Nothing And myTreffer <> myBedingung.Address
     
   End If
                     
           ThisWorkbook.Worksheets("Tabelle1").Cells(1, 8).Resize(UBound(myMAGruppe, 1)).Value = myMAGruppe

[Kuwer]

Hallo,

z.B. so:

Sub abc()
  Dim myBedingung As Range
  Dim myTreffer As String
  Dim myMAGruppe() As Variant
  Dim myArrayPos As Long
  
  With Range("G5:G10")
    Set myBedingung = .Find(what:="1", after:=.Cells(.Cells.Count))
    If Not myBedingung Is Nothing Then
      ReDim myMAGruppe(1 To .Cells.Count, 1 To 1)
      myTreffer = myBedingung.Address
      Do
        myArrayPos = myArrayPos + 1
        If myBedingung.Value = "1" Then
          myMAGruppe(myArrayPos, 1) = myBedingung.Offset(0, -4).Value
        End If
        Set myBedingung = .FindNext(myBedingung)
      Loop While Not myBedingung Is Nothing And myTreffer <> myBedingung.Address
      ThisWorkbook.Worksheets("Tabelle1").Cells(1, 8).Resize(UBound(myMAGruppe, 1)).Value = myMAGruppe
    End If
  End With
End Sub

Gruß Uwe

[schauan]

Hallöchen,

Du könntest auch per Makro nach dem Suchbegriff filtern, G5:G10 kopieren, in H1 einfügen und dann den Filter wieder aufheben. Beim kopieren werden nur die sichtbaren Zellen mitgenommen.

[Gast_1979]

Vielen Dank an euch beide !

Eine Frage noch an Uwe:
Im Moment werden die gefundenen Strings ( sind aktuell 3 Stück ) in H1, H2 und H3 geschrieben.
Geht es, dass alle in H1 untereinander geschrieben werden?

Danke und Grüße!

[schauan]

Hallöchen,

hier mal zwischendurch mein Ansatz mit dem Autofilter. Schaue Dir dabei auch das Join an, das kannst DU anlog in Uwe's Code verwenden, um die Daten in H1 auszugeben.

Code:

Sub Makro1()
'schauan
Dim arrH
'mit dem Bereich G5:G10
With ActiveSheet.Range("G5:G10")
  'Filter setzen
  .AutoFilter
  .AutoFilter Field:=1, Criteria1:="A"
  'gefilterte Daten nach H1 kopieren
  .Copy Range("H1")
  'Filter zuruecksetzen
  .AutoFilter
'Ende mit dem Bereich G5:G10
End With
'Kopiermodus zuruecksetzen
Application.CutCopyMode = False
'Daten aus Salte H uebernehmen und Array zuweisen
arrH = WorksheetFunction.Transpose(Range("H1:H" & Cells(Rows.Count, "H").End(xlUp).Row).Value)
'Spalte H komplett leeren
Columns(8).Value = ""
'Array nach H1 nehmen
Range("H1").Value = Join(arrH, Chr(10))
End Sub

[Kuwer]

Geht es, dass alle in H1 untereinander geschrieben werden?

Dann vereinfacht so:

Sub cba()
  Dim myBedingung As Range
  Dim myTreffer As String
  Dim myMAGruppe As String
  
  With Range("G5:G10")
    Set myBedingung = .Find(what:="1", after:=.Cells(.Cells.Count))
    If Not myBedingung Is Nothing Then
      myTreffer = myBedingung.Address
      Do
        If myBedingung.Value = "1" Then
          myMAGruppe = myMAGruppe & vbNewLine & myBedingung.Offset(0, -4).Value
        End If
        Set myBedingung = .FindNext(myBedingung)
      Loop While Not myBedingung Is Nothing And myTreffer <> myBedingung.Address
      ThisWorkbook.Worksheets("Tabelle1").Cells(1, 8).Value = Mid(myMAGruppe, 3)
    End If
  End With
End Sub

Gruß Uwe

[Gast_1979]

Das ist ja genial - beide Lösungen!

Vielen, vielen Dank!