Koddaki değişiklik

[Erdinç FIRTINA]

Değerli üyeler,
Sayın Orion2'nin hazırlamış olduğu kod üzerinde çalışarak kendime uyarlamaya çalıştım. Şimdilik kendi isteğime göre uyarlayabildiğimi düşünüyorum. Ancak aşağıda belirtilen, aktarılan verilerin bulunduğu sütunun başlangıç satırı ve bitiş satırını nasıl yazacağımı bulamıyorum. Konuyla ilgili yardımlarınız için şimdiden teşekkürler!!!

Koddaki 9.satır. Söz konusu satırdaki (10, "H") ile H sütunununda bulunan verilerden 10.satıra kadar olanları alıp aktarabiliyorum. Oysa benim istediğim ise, örneğin H sütunundaki 5.satırdan başlayıp 20.satıra kadar yer alan verileri alıp aktarmaktır. Bunun için nasıl bir değişiklik yapabilirim?

sat = Sheets(i).Cells(10, "H").End(xlUp).Row


Sub aktar()
Dim sno As Long, sat2 As Long, sat As Long, sonsat As Long
Dim i As Integer, k As Long
Application.ScreenUpdating = False
Sheets("GELİRLER").Range("A3:E65536").ClearContents
sno = 1: sat2 = 3
For i = 1 To Worksheets.Count
If Sheets(i).Name >= 1 And Sheets(i).Name <= 31 Then
sat = Sheets(i).Cells(10, "H").End(xlUp).Row
If sat >= 4 Then
For k = 4 To sat
adr1 = Range(Cells(k, "G"), Cells(k, "I")).Address
adr2 = Range(Cells(sat2, "B"), Cells(sat2, "D")).Address
Cells(sat2, "A").Value = sno
Sheets("GELİRLER").Range(adr2).Value = Sheets(i).Range(adr1).Value
Sheets("GELİRLER").Cells(sat2, "E").Value = Sheets(i).Range("F1").Value
sat2 = sat2 + 1
sno = sno + 1
Next k
End If
End If
Next i
sonsat = Sheets("GELİRLER").Cells(65536, "C").End(xlUp).Row
Sheets("GELİRLER").Cells(sonsat + 1, "C").Value = "TOPLAM...YTL...:"
Sheets("GELİRLER").Cells(sonsat + 1, "D").Value = _
WorksheetFunction.Sum(Sheets("GELİRLER").Range("D3" & sonsat))
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANDI..!!"
End Sub


a

 

[Orion1]

Merhaba.
Aşağıdaki kodlarda kırmızı yazan yerleri değitirip deneyiniz.

Sub aktar()
Dim sno As Long, sat2 As Long, sat As Long, sonsat As Long
Dim i As Integer, k As Long
Application.ScreenUpdating = False
Sheets("GELİRLER").Range("A3:E65536").ClearContent s
sno = 1: sat2 = 3
For i = 1 To Worksheets.Count
If Sheets(i).Name >= 1 And Sheets(i).Name <= 31 Then
[COLOR="Red"]sat = Sheets(i).Cells(65536, "H").End(xlUp).Row[/COLOR]
If sat >= 4 Then
[COLOR="red"]For k = 5 To 20[/COLOR]

 

[Erdinç FIRTINA]

Say&#305;n Orion2,
&#199;ok te&#351;ekk&#252;rler!!!
Denedim problem yok gibi g&#246;r&#252;n&#252;yor ama &#351;imdide tarihlerin aktar&#305;ld&#305;&#287;&#305; s&#252;tuna sadece ektar&#305;lan sat&#305;rlara ait tarihleri yazmakla kalmay&#305;p &#231;ok say&#305;da sat&#305;ra ait tarih aktar&#305;yor hatta bir de verilerin olmad&#305;&#287;&#305; bo&#351; sat&#305;r kadar da sat&#305;r a&#231;&#305;yor Bunun nedeni ne olabilir acaba?

 

[Orion1]

5nci satırdan 20nci satıra kadar olan verileri aktarmak istemiştiniz.
Bende 5 ten 20 ye kadar döngüye giren kodları yazdım.O sebeple boşta olsa 5den 20 ye kadar olan satırları listeliyor.

 

[Erdinç FIRTINA]

Say&#305;n Orion2,
Ama sat&#305;r a&#351;a&#287;&#305;daki gibi iken t&#252;m s&#252;tundaki sat&#305;rlardan sadece dolu olanlar&#305; al&#305;p aktar&#305;yordu bo&#351; olanlar&#305; alm&#305;yordu. Bunun nedeni ne olabilir?
Neyse sizi de yormak istemiyorum. Benim i&#231;in &#246;nemliydi ama olmayacak bir &#351;eyse yap&#305;lacak bir &#351;ey yok.


sat = Sheets(i).Cells(65536, "H").End(xlUp).Row
If sat >= 4 Then
For k = 4 To sat

 

[Orion1]

sat = Sheets(i).Cells(65536, "H").End(xlUp).Row
If sat >= 4 Then
For k = 4 To sat

Bu durumda 20nci sat&#305;rdan fazla veri varsa onuda g&#246;sterir.
Siz 20nci sat&#305;rdan azsa onlar&#305; listelenmesini 20nci sat&#305;rdan fazla ise 20nci sat&#305;ra kadar listelenmesini istiyorsunuz?
E&#287;er &#246;yle ise kodlar&#305; o &#351;ekilde d&#252;zenleyebilirim.

 

[Erdinç FIRTINA]

Sayın Orion2,
Benim aktarılacak sütundaki verilerim örneğin H sütununun 4. satırında başlıyor 20. satıra kadar gidebiliyor ancak her zaman 4-20 satırlar arasındaki veriler dolu değil.
Örneğin; Sayfa1 de H4, H5, H6 dolu diğerleri boş ama Sayfa 2 de ise H4-H20 arasındaki satırların hepsi dolu. Ben sadece dolu satırlardaki verileri almasını diğerlerini ise almamasını istiyorum.

Aslında ben bu çalışmada sizin kod yazdığınız ilk dosyadaki duruma göre uyarlamaya çalışıyorum. Çünkü sizin ilk yazdığınız dosyadaki kodlar sayfaların diğer bölümlerinden almak istediğim verilerin düzeni ile aynı değil. Ben kodları ona göre uyarlamaya çalışıyorum.

Sizin yazdığınız ilk koda göre problem yoktu.

Hatta dosyamı tekrar gönderiyorum. Ne yapmak istediğim belki daha iyi anlaşılabilir.

 

[Orion1]

Ekli dosyayı inceleyiniz.
Giderleride raporluyor.
Giderler sayfasında Butona basın sonucu gözlemleyiniz.

Sub gider_rapor()
Dim sno As Long, sat2 As Long, sat As Long, sonsat As Long
Dim i As Integer, k As Long
Application.ScreenUpdating = False
Sheets("GİDERLER").Range("A3:E65536").ClearContents
sno = 2: sat2 = 3
For i = 1 To Worksheets.Count
    If Sheets(i).Name >= 2 And Sheets(i).Name <= 31 Then
        sat = Sheets(i).Cells(20, "G").End(xlUp).Row
        If sat > 18 Then sat = 18
        If sat >= 4 Then
        For k = 4 To sat
            adr1 = Range(Cells(k, "G"), Cells(k, "I")).Address
            adr2 = Range(Cells(sat2, "B"), Cells(sat2, "D")).Address
            Sheets("GİDERLER").Cells(sat2, "A").Value = sno
            Sheets("GİDERLER").Range(adr2).Value = Sheets(i).Range(adr1).Value
            Sheets("GİDERLER").Cells(sat2, "E").Value = Sheets(i).Range("A1").Value
            sat2 = sat2 + 1
            sno = sno + 1
        Next k
        End If
    End If
Next i
sonsat = Sheets("GİDERLER").Cells(65536, "B").End(xlUp).Row
Sheets("GİDERLER").Cells(sonsat + 1, "C").Value = "TOPLAM...YTL...:"
Sheets("GİDERLER").Cells(sonsat + 1, "D").Value = _
WorksheetFunction.Sum(Sheets("GİDERLER").Range("D3:D" & sonsat))
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANDI..!!"
End Sub

 

[Erdinç FIRTINA]

Say&#305;n Orion2,
Size nas&#305;l te&#351;ekk&#252;r edece&#287;imi bilemiyorum.
Ger&#231;ekten &#231;ok iyi oldu.
Her&#351;ey i&#231;in tekrar tekrar te&#351;ekk&#252;rler!!!

 

[Orion1]

Sayın Orion2,
Size nasıl teşekkür edeceğimi bilemiyorum.
Gerçekten çok iyi oldu.
Herşey için tekrar tekrar teşekkürler!!!

Rica ederim.
İyi çalışmalar.