Soru VBA İle Koşula Göre Kopyalama

[berkem13]

Merhabalar, hazırlamış olduğum excel dosyasında vba ile otomatik kopyalama işlemi yaptırmak istiyorum. Daha da detaylı anlatmak gerekirse resimde de görüleceği üzere "İşlem" sütununda dolu olan yere kadar kopyalamasını istiyorum. Eğer 1 satır "İşlem" varsa 1 satırı, 10 tane "İşlem" varsa 10 satırı kopyalanması gerekiyor. Şimdiden vereceğiniz cevaplardan dolayı teşekkür ederim.

 

[YUSUF44]

Neyi nereye kopyalamak istiyorsunuz?

 

[berkem13]

Neyi nereye kopyalamak istiyorsunuz?

Hocam ilk resimde "İşlem" sütünu dolu olan satırları aşağıdaki resimde gözüken excelin son satırına kopyalamak istiyorum. Normalde aşağıdaki kodları kullanarak kopyalama işlemi yapıyorum ancak sabit alanları kopyalarsam sıkıntı olacaktır. Ondan dolayı koşullu kopyalamam gerekiyor.

Sub CekveSenetKayıt()
'
' CekveSenetKayıt Makro
'

'
    Range("I27:I35").Select
    Selection.Copy
    Workbooks.Open ActiveWorkbook.Path & "\Çek Defteri.xlsm"
    Worksheets("Liste").Select
    Application.Goto Reference:="R6000C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    ActiveWindow.SmallScroll Down:=-3
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveWorkbook.Save
    ActiveWindow.Close
    Application.CutCopyMode = False
    Worksheets("Özet").Range("I25").Select
End Sub

İstediğim satırları başka excel sayfasına kopyalama işlemini yukarıdaki kodlarla yapıyorum hocam.

 

[YUSUF44]

İnşallah bir anlayan çıkar. Ya da kolaylaştırmak için resim değil de excel dosyası paylaşın ve örnek olarak bir kopyalama yapın ki ne istediğinizi anlayabilelim.

 

[berkem13]

İnşallah bir anlayan çıkar. Ya da kolaylaştırmak için resim değil de excel dosyası paylaşın ve örnek olarak bir kopyalama yapın ki ne istediğinizi anlayabilelim.

Hocam birden fazla dosya var. Dosyaları paylaştığımda anlatmam daha çok zorlaşacak. Alabilirsem ekran kaydı alıp atayım hocam.

 

[YUSUF44]

Özel mesajla gönderdiğiniz videoda anlattığınız konuyla ilgili anladığım kadarıyla yardımcı olmaya çalışayım. Yukardaki kodları videoda anlattığınız duruma göre uyarladığımızda kopyalama satırlarını aşağıdakiyle değiştirmeniz yeterli olur diye düşünüyorum:

son = Cells(Rows.Count, "R").End(3).Row
    Range("Q42:AF" & son).Copy

 

[berkem13]

Özel mesajla gönderdiğiniz videoda anlattığınız konuyla ilgili anladığım kadarıyla yardımcı olmaya çalışayım. Yukardaki kodları videoda anlattığınız duruma göre uyarladığımızda kopyalama satırlarını aşağıdakiyle değiştirmeniz yeterli olur diye düşünüyorum:

son = Cells(Rows.Count, "R").End(3).Row
    Range("Q42:AF" & son).Copy

Üstadım, kodu şu şekilde değiştirdim ancak resimdeki gibi boş satırlarda kopyalanıyor.

Sub FaturasıKesilmeyenNP()
'
' FaturasıKesilmeyenNP Makro
    
    ' Müşteri Türü ve Dosya Yolu Belirleme
    Dim MusteriTuru As Variant
    MusteriTuru = Worksheets("Sabitler").Range("B6")
    Dim DosyaYolu As Variant
    If MusteriTuru = 1 Then
    DosyaYolu = ActiveWorkbook.Path & "\Nakliyeciler\" & Worksheets("Özet").Range("C4") & ".xlsx"
    ElseIf MusteriTuru = 2 Then
    DosyaYolu = ActiveWorkbook.Path & "\Petrolcüler\" & Worksheets("Özet").Range("C4") & ".xlsx"
    End If
    son = Cells(Rows.Count, "R").End(3).Row ' Kopyalama İçin Gerekli Kod
    Range("Q42:AF" & son).Copy ' Kopyalama İçin Gerekli Kod
    Workbooks.Open DosyaYolu
    Worksheets("Detay").Select
    Application.Goto Reference:="R6000C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveWorkbook.Save
    ActiveWindow.Close
    Application.CutCopyMode = False
    Worksheets("Özet").Range("B43").Select

End Sub

 

[YUSUF44]

Aslına uygun örnek dosya olmadan daha fazlası beni aşıyor maalesef.

 

[berkem13]

Aslına uygun örnek dosya olmadan daha fazlası beni aşıyor maalesef.

Sorunu aşağıdaki kod ile çözdüm. İlginizden dolayı teşekkürler hocam.

    Set x = [R42:R49].Find("*", LookIn:=xlValues, SearchDirection:=xlPrevious)
    Range("Q42:AF" & x.Row).Select
    Selection.Copy