Aktar makrosunun revize edilmesi gerekiyor.

[s.savas]

Arkadaşlar iyi akşamlar.
Aşağıdaki kod ile ekte sunulan belgenin İcmal sayfasında bulunan Aktar butonu ile 1 den 8 numaralı sayfalara kadar olan sekmelerdeki A34, Y34,AD34, AI34 ve AN34 numaralı hücrelerindeki verileri B8 -F15 aralığına alıyorum. Ancak verileri almaya başlarken 8.sayfadan başlayıp 1.sayfada bitiriyor. Bu işlemi 1.sayfadan başlayıp 8. sayfada bitirmesini istiyorum.
İlgilenecek arkadaşlara teşekkür ederim.

Private Sub CommandButton1_Click()
Dim i As Integer, s As Worksheet, toplam As Double
Set s = Sheets("İcmal")
For i = 1 To Sheets.Count
If CStr(Sheets(i).Name) = CStr(i - 6) Then
s.Range("b8").Value = Sheets(i).Range("a34").Value
s.Range("c8").Value = Sheets(i).Range("y34").Value
s.Range("d8").Value = Sheets(i).Range("ad34").Value
s.Range("e8").Value = Sheets(i).Range("aI34").Value
s.Range("f8").Value = Sheets(i).Range("aN34").Value
On Local Error Resume Next
toplam = toplam + s.Range("f8").Value
Err.Clear
If i = Sheets.Count Then Exit For
Rows("8:8").Insert Shift:=xlDown
End If
Next i
s.Range("e65536").End(3)(1, 2).Value = toplam
i = Empty: toplam = Empty: Set s = Nothing
End Sub

 

[halit3]

böyle denermisiniz.

Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, r As Integer, s As Worksheet, toplam As Double
Set s = Sheets("İcmal")
j = 8
For i = 1 To Sheets.Count
If CStr(Sheets(i).Name) = CStr(i - 6) Then
r = r + 1
s.Cells(j, "a").Value = r
s.Cells(j, "b").Value = Sheets(i).Range("a34").Value
s.Cells(j, "c").Value = Sheets(i).Range("y34").Value
s.Cells(j, "d").Value = Sheets(i).Range("ad34").Value
s.Cells(j, "e").Value = Sheets(i).Range("aI34").Value
s.Cells(j, "f").Value = Sheets(i).Range("aN34").Value
s.Range("A" & j & ":F" & j).Select
Selection.Borders(7).LineStyle = xlContinuous
Selection.Borders(8).LineStyle = xlContinuous
Selection.Borders(9).LineStyle = xlContinuous
Selection.Borders(10).LineStyle = xlContinuous
Selection.Borders(11).LineStyle = xlContinuous
On Local Error Resume Next
toplam = toplam + Sheets(i).Range("aN34").Value
j = j + 1
Err.Clear
If i = Sheets.Count Then Exit For
Rows(j).Insert Shift:=xlDown
End If
Next i
s.Range("e65536").End(3)(1, 2).Value = toplam
i = Empty: toplam = Empty: Set s = Nothing
End Sub

 

[halit3]

kod aşağıdaki mesajda

 

[halit3]

bu kodu denermisiniz. sayı değeri olan sayfaların hepsinden verileri alıyor.

Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, s As Worksheet, toplam As Double
Set s = Sheets("İcmal")
j = s.Cells(Rows.Count, "B").End(3).Row + 1
For i = 1 To Sheets.Count
If IsNumeric(Sheets(i).Name) = True Then
s.Cells(j, "a").Value = j - 7
s.Cells(j, "b").Value = Sheets(i).Range("a34").Value
s.Cells(j, "c").Value = Sheets(i).Range("y34").Value
s.Cells(j, "d").Value = Sheets(i).Range("ad34").Value
s.Cells(j, "e").Value = Sheets(i).Range("aI34").Value
s.Cells(j, "f").Value = Sheets(i).Range("aN34").Value
s.Cells(j, "e").Font.Bold = False
s.Cells(j, "f").Font.Bold = False
s.Range("A" & j & ":F" & j).Select
Selection.Borders(7).LineStyle = xlContinuous
Selection.Borders(8).LineStyle = xlContinuous
Selection.Borders(9).LineStyle = xlContinuous
Selection.Borders(10).LineStyle = xlContinuous
Selection.Borders(11).LineStyle = xlContinuous
toplam = toplam + Sheets(i).Range("aN34").Value
j = j + 1
End If
Next i
s.Cells(j, "e").Value = "Toplam Tutar"
s.Cells(j, "f").Value = toplam
s.Cells(j, "F").Value = WorksheetFunction.Sum(s.Range("F8:F" & j - 1))
s.Cells(j, "e").Font.Bold = True
s.Cells(j, "f").Font.Bold = True
s.Cells(j + 6, "a").Value = "Üye"
s.Cells(j + 6, "c").Value = "Üye"
s.Cells(j + 6, "f").Value = "Üye"
End Sub

 

[s.savas]

böyle denermisiniz.

Halit hocam çok teşekkürler yazdığınız kod mükemmel çalışıyor ve tam istediğim gibi.
Yazdığınız kodunuzu kullanmak istediğim orjinal dosyama uyarladım, ancak bir iki ufak sorun yaşadım, sorunun kaynağını deneme yanılma ile bulamadım.

Sorunumu ekteki dosyada izah etmeye çalıştım.

 

[halit3]

uyarı ! yardım isterken dosyanızın orjinal halini göndermeye,gönderilen dosyada özel bilgileriniz olmamasına ve küçük boyutta olmasına özen gösteriniz. yoksa kodu yeniden revize etmek gerekiyor.

aşağıdaki kodu denermisiniz.

Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, s As Worksheet, toplam As Double
Set s = Sheets("İcmal")
j = s.Cells(Rows.Count, "B").End(3).Row + 1
For i = 1 To Sheets.Count
If IsNumeric(Sheets(i).Name) = True Then
s.Cells(j, "a").Value = j - 16
s.Cells(j, "b").Value = Sheets(i).Range("a34").Value
s.Cells(j, "c").Value = Sheets(i).Range("y34").Value
s.Cells(j, "d").Value = Sheets(i).Range("ad34").Value
s.Cells(j, "e").Value = Sheets(i).Range("aI34").Value
s.Cells(j, "f").Value = Sheets(i).Range("aN34").Value
s.Cells(j, "e").Font.Bold = False
s.Cells(j, "f").Font.Bold = False

toplam = toplam + Sheets(i).Range("aN34").Value
j = j + 1
End If
Next i
s.Range("A17" & ":F" & j - 1).Select
Selection.Borders(7).LineStyle = xlContinuous
Selection.Borders(8).LineStyle = xlContinuous
Selection.Borders(9).LineStyle = xlContinuous
Selection.Borders(10).LineStyle = xlContinuous
Selection.Borders(11).LineStyle = xlContinuous
Selection.Borders(12).LineStyle = xlContinuous

s.Cells(j, "e").Value = "Toplam Tutar"
s.Cells(j, "f").Value = toplam
s.Cells(j, "F").Value = WorksheetFunction.Sum(s.Range("F17:F" & j - 1))
s.Cells(j, "e").Font.Bold = True
s.Cells(j, "f").Font.Bold = True
s.Cells(j + 6, "a").Value = "Üye"
s.Cells(j + 6, "c").Value = "Üye"
s.Cells(j + 6, "f").Value = "Üye"
End Sub

 

[s.savas]

Halit hocam uyarınız için teşekkür ederim. Makro bilgim çok zayıf olduğu için hangi kodun ne görev yaptığını deneme yanılma yöntemi ile öğrenmeye çalışıyorum, o yüzden ilk mesajda örnek dosya eklemiştim.

5. mesajdaki orjinal dosyada 36,39,40 ve 41. satırlarda silinmemesi gereken veriler var, bu yüzden 17.satırdan itibaren yaklaşık maliyetlerden alınan verilerin satır eklenerek alınması gerekmekte idi.
2. mesajda yazdığınız kod bu işi tam anlamı ile yerine getiriyor. Sadece 5 numaralı mesajda ifade ettiğim hatalarımın giderilmesi sorunun çözümüne yeterli olacağını düşünüyorum.

 

[halit3]

sayfanın sabit olduğunu düşünerek kodu yeniden düzenledim 36,39,40,41 nolu satılardaki verileride otomatik atıyor.

 

[assenucler]

Emek ve katkı için teşekkürler ve iyi hafta sonları...

 

[s.savas]

sayfanın sabit olduğunu düşünerek kodu yeniden düzenledim 36,39,40,41 nolu satılardaki verileride otomatik atıyor.

Hocam çok teşekkürler.

 

[halit3]

Hocam çok teşekkürler.

iyi çalışmalar