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
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
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.
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!
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
(12.11.2017, 14:15)Gast_1979 schrieb: [ -> ]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
Das ist ja genial - beide Lösungen!
Vielen, vielen Dank!