2 sütunda çalışan makroyu 10 sütunda çalıştırmak

[ertmer]

işime çok yarayan bu makroyu acaba 10 sütunda çalışacak hale getirebilirmiyiz yardımcı olanlara şimdiden teşekkürler

 

[ertmer]

özürdileyerek eksik yüklediğim dosyayı tekrar yüklüyorum ihtiyacım olan 1.sayfadaki a sütunundaki aynı verileri süzüp b-c-d-e-f-g-h-ı sütunlarındaki verilerin toplamını alarak 2. sayfaya aktarmek

 

[ertmer]

yardımcı olanlara şimdiden çok teşekkürler

 

[Emir Hüseyin Çoban]

. . .

Şu şekilde deneyiniz.

Sub aktar()
    Dim isim, deger As Variant
    Dim rng As Range
    Dim i, z As Integer
    i = 2
    z = 1
    Do
        If Cells(i, 1).Value = "" Then GoTo bitti
        If Range([A1], [A10000]).Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Row < i Then GoTo devam2
        ReDim isim(z)
        ReDim deger(z)
        isim(z) = Cells.Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Value
        'deger(z) = Cells(i, 1).Offset(0, 1).Value
        deger(z) = WorksheetFunction.Sum(Range(Cells(i, "B"), Cells(i, "I")))
        hcr = i
        Do
            On Error Resume Next
            Set rng = Range(Cells(hcr, 1), [A10000]).FindNext
            If rng.Row = hcr Then GoTo devam
            hcr = rng.Row
            'deger(z) = deger(z) + rng.Offset(0, 1).Value
            deger(z) = deger(z) + WorksheetFunction.Sum(Range(Cells(rng.Row, "B"), Cells(rng.Row, "I")))
        Loop
devam:
        Sheets(2).Cells(z, 1).Value = isim(z)
        Sheets(2).Cells(z, 2).Value = deger(z)
        z = z + 1
devam2:
        i = i + 1
    Loop
bitti:
End Sub

. . .

 

[ertmer]

hocam ilgilendiğiniz için çok teşekkürler
fakat ben kendimi tam ifade edememişim 1. sayfadaki b-c-d-e-f-g-h-ı sütunlarındaki toplamları diğer sayfadaki b-c-d-e-f-g-h-ı sütunlarına almamlazım yardımlarınızdan dolayı çok teşekkürler

 

[Emir Hüseyin Çoban]

. . .

Sub aktar()
    Dim isim, deger1, deger2, deger3, deger4, deger5, deger6, deger7, deger8
    Dim rng As Range
    Dim i, z As Integer
    i = 2
    z = 1
    Do
        If Cells(i, 1).Value = "" Then GoTo bitti
        If Range([A1], [A10000]).Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Row < i Then GoTo devam2
        
        ReDim isim(z)
        ReDim deger1(z): ReDim deger2(z): ReDim deger3(z): ReDim deger4(z)
        ReDim deger5(z): ReDim deger6(z): ReDim deger7(z): ReDim deger8(z)
        
        isim(z) = Cells.Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Value
        deger1(z) = Cells(i, 1).Offset(0, 1).Value
        deger2(z) = Cells(i, 1).Offset(0, 2).Value
        deger3(z) = Cells(i, 1).Offset(0, 3).Value
        deger4(z) = Cells(i, 1).Offset(0, 4).Value
        deger5(z) = Cells(i, 1).Offset(0, 5).Value
        deger6(z) = Cells(i, 1).Offset(0, 6).Value
        deger7(z) = Cells(i, 1).Offset(0, 7).Value
        deger8(z) = Cells(i, 1).Offset(0, 8).Value
        
        hcr = i
        Do
            On Error Resume Next
            Set rng = Range(Cells(hcr, 1), [A10000]).FindNext
            If rng.Row = hcr Then GoTo devam
            hcr = rng.Row
            deger1(z) = deger1(z) + rng.Offset(0, 1).Value
            deger2(z) = deger2(z) + rng.Offset(0, 2).Value
            deger3(z) = deger3(z) + rng.Offset(0, 3).Value
            deger4(z) = deger4(z) + rng.Offset(0, 4).Value
            deger5(z) = deger5(z) + rng.Offset(0, 5).Value
            deger6(z) = deger6(z) + rng.Offset(0, 6).Value
            deger7(z) = deger7(z) + rng.Offset(0, 7).Value
            deger8(z) = deger8(z) + rng.Offset(0, 8).Value
        Loop
devam:
        Sheets(2).Cells(z, 1).Value = isim(z)
        Sheets(2).Cells(z, 2).Value = deger1(z)
        Sheets(2).Cells(z, 3).Value = deger2(z)
        Sheets(2).Cells(z, 4).Value = deger3(z)
        Sheets(2).Cells(z, 5).Value = deger4(z)
        Sheets(2).Cells(z, 6).Value = deger5(z)
        Sheets(2).Cells(z, 7).Value = deger6(z)
        Sheets(2).Cells(z, 8).Value = deger7(z)
        Sheets(2).Cells(z, 9).Value = deger8(z)
        
        z = z + 1
devam2:
        i = i + 1
    Loop
bitti:
End Sub

. . .

 

[ertmer]

hocam ellerinize sağlık çok teşekkür ederim
sorunum çözüldü

 

[ertmer]

sayenizde işim çok kolaylaştı