VBA yardım

[Oppenheimer]

Sub KopyalaYapistir()

    Dim ilkAralik As Range, ikinciAralik As Range, ucuncuAralik As Range, hedefAralik As Range
    Dim aramaAraligi As String
    
    aramaAraligi = Sheets("Data").Range("A1").Value
    Set ilkAralik = Range("A:A").Find("*" & aramaAraligi & "*", LookIn:=xlValues, LookAt:=xlPart)
    Set ikinciAralik = ilkAralik.End(xlDown)
    Set ucuncuAralik = ikinciAralik.End(xlDown)
    
    If Not ikinciAralik Is Nothing And Not ucuncuAralik Is Nothing Then
        
        Set hedefAralik = Range(ikinciAralik.Offset(1, 0), ucuncuAralik.Offset(-1, 0)).Resize(10, 15)

        hedefAralik.Copy Range("Z2")
    Else
        MsgBox " bulunamadı."
    End If

End Sub

Arkadaşlar iyi akşamlar sorunum şu şimdi Data sayfasında A1 hücresine atıyorum gül yazıyor A20 hücresinde gül 10 yazıyor böyle böyle gidiyor ben 2. ve 3. gül yazısı içeren konumlar arasındaki verileri A:O sütun satır genişliğinde kopyalayıp Z2 hücresine yapıştırmak istiyorum. 2. gül yazan yerde dahiil olacak ama 3.gül yazan yer dahil olmayacak. (burada gül sadece örnek A1 hücresini baz alıyorum oradaki veriye göre yapıyorum yani).Yukarıda örnek yaptım ama o örnek aşağı doğru 10 hücreyi alıyo ben 3. gül yazan yere kadar almak istiyorum dinamik olması lazım yani umarım anlatabilmişimdir.

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
Deneyiniz ...

Sub iki_aralik()
    Dim x As Long, yy1 As Long, yy2 As Long
    son = Cells(Rows.Count, "A").End(3).Row
    aa = Cells(1, 1): bb = Len(aa)
        For x = 2 To son
            Cells(x, 1).Select
                If Left(Cells(x, 1), bb) = aa Then yy1 = x
                If yy1 <> 0 Then
                    GoTo 98
                  Else
                End If
        Next x
98:
        For x = yy1 + 1 To son
            Cells(x, 1).Select
                If Left(Cells(x, 1), bb) = aa Then yy2 = x
                If yy2 <> 0 Then
                    GoTo 99
                  Else
                End If
        Next x
99:
    Range("A1:O" & yy2 - 1).Select
    Selection.Copy
    Range("Z2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("Z1").Select
End Sub

iyi çalışmalar

 

[veyselemre]

Sub test()
    
    Dim c As Range, c1 As Range, c2 As Range
    
    Set c2 = Cells(Rows.Count, 1).End(3)

    With Range("A2", c2)
        Set c = .Find("*" & Range("A1").Value & "*", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Set c1 = c
            Set c = .FindNext(c)
            If Not c Is Nothing And c.Address <> c1.Address Then Set c2 = c.Offset(-1)
            Intersect(Range(c1, c2).EntireRow, Range("A:O")).Copy Range("Z2")
        End If
    End With

End Sub

 

[Oppenheimer]

Kusura bakmayın bildirimi görmemişim biraz geç oldu ama şuan denedim kodları ikinize de çok teşekkür ederim iki kodda çok güzel çalışıyor.