belirtilen toplamdan fazla ise yeni sayfaya atma

[kadirdiloglu]

Merhaba,

Ekte yer alan dosyamda E sütununda yer alan ücretleri her 100.000 i aşan bölgeyi yeni sayfada açmasını sağlayabilir miyiz? yani ilk 100.000 tl lik toplamı bir sayfa 2. 100.000 tl lik toplamı 2 .sayfa böyle gitmesi gerekiyor.

http://s8.dosya.tc/server/nszaqt/DOSYA_DENEME.xlsx.html

 

[PLİNT]

Merhaba,
Ekte yer alan dosyamda E sütununda yer alan ücretleri her 100.000 i aşan bölgeyi yeni sayfada açmasını sağlayabilir miyiz? yani ilk 100.000 tl lik toplamı bir sayfa 2. 100.000 tl lik toplamı 2 .sayfa böyle gitmesi gerekiyor.

Merhaba
Ek dosyayı deneyiniz;

http://s3.dosya.tc/server7/xe0due/Kopya_DOSYA_DENEME.zip.html
"E1" hücresi seçildiğinde kodlar çalışacaktır.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address <> "$E$1" Then Exit Sub
   Sheets.Add After:=Sheets(Sheets.Count)
Sheets(1).Rows("1:4").Copy Sheets(Sheets.Count).[a1]
   For s = 1 To 9
Sheets(Sheets.Count).Columns(s).ColumnWidth = Sheets(1).Columns(s).ColumnWidth
Next
x = 4
   For a = 5 To Cells(Rows.Count, "d").End(3).Row
   x = x + 1
Range("A" & a & ":I" & a).Copy Sheets(Sheets.Count).Range("A" & x)
topla = Cells(a, "D") + topla
If topla + Cells(a + 1, "D") > 100000 Then
Sheets.Add After:=Sheets(Sheets.Count)
Rows("1:4").Copy Sheets(Sheets.Count).[a1]
 For s = 1 To 9
Sheets(Sheets.Count).Columns(s).ColumnWidth = Sheets(1).Columns(s).ColumnWidth
Next
Sheets(1).Rows("1:4").Copy Sheets(Sheets.Count).[a1]
x = 4: topla = 0
End If
Next

End Sub

 

[kadirdiloglu]

Merhaba
Ek dosyayı deneyiniz;

http://s3.dosya.tc/server7/xe0due/Kopya_DOSYA_DENEME.zip.html
"E1" hücresi seçildiğinde kodlar çalışacaktır.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address <> "$E$1" Then Exit Sub
   Sheets.Add After:=Sheets(Sheets.Count)
   For s = 1 To 9
Sheets(Sheets.Count).Columns(s).ColumnWidth = Sheets(1).Columns(s).ColumnWidth
Next
   For a = 5 To Cells(Rows.Count, "d").End(3).Row
   x = x + 1
Range("A" & a & ":I" & a).Copy Sheets(Sheets.Count).Range("A" & x)
topla = Cells(a, "D") + topla
If topla + Cells(a + 1, "D") > 100000 Then
Sheets.Add After:=Sheets(Sheets.Count)
 For s = 1 To 9
Sheets(Sheets.Count).Columns(s).ColumnWidth = Sheets(1).Columns(s).ColumnWidth
Next
x = 1: topla = 0
End If
Next
End Sub

öncelikle teşekkürler tam istediğim gibi...1.2.3.4. satırları da yeni sayfayla birlikte taşıyabilir miyiz?

 

[PLİNT]

öncelikle teşekkürler tam istediğim gibi...1.2.3.4. satırları da yeni sayfayla birlikte taşıyabilir miyiz?

Merhaba
Yukarıdaki değişen kodları deneyin.

 

[kadirdiloglu]

Merhaba
Yukarıdaki değişen kodları deneyin.

elinize sağlık ....harikasınız