• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

çoketopla makro ile

  • Konbuyu başlatan Konbuyu başlatan walabi
  • Başlangıç tarihi Başlangıç tarihi
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
1,080
Excel Vers. ve Dili
excel 2010

excel 2013
Merhaba,

Ekteki dosyada normal bir çoketopla fonksiyonu uygulaması mevcut. Bu fonksiyonu makroya nasıl çevirebiliriz. Bu işlemi özet tablo şeklinde yapılabilir diyenler olabilir. Ancak veriler hem çok fazla hem de ekteği Tablo adlı sayfadaki uygulamaya benzer bir makrı çözüm daha kullanışlı gelmekte bana göre. Forumda biryerde benzeri bir uygulama vardı ancak tam olarak benim istedim uygulamaya benzemiyordu. Eni boyu değişebilecek bir çözüm üretmem gerekli. Sanırım yazılacak kodda sayfa adları ve sütunlar belirtilecektir. İlgili kodda sayfa adını ve sütunları değiştirebiliyor olmam gerekli.

Teşekkürler,
 

Ekli dosyalar

Benzeri bir soru daha önce aşağıda olduğu gibi gelmiş ve cevaplanmış.

SORU

=ÇOKETOPLA(satış!$K:$K;satış!$A:$A;$H$2;satış!$E:$ E;$E3)

bu formulu yaşlandırma adında sayfanın h3 hücresine yazıp aşağı doğru çekip
e stunun girilmiş verilere göre satış sayfasından çekip işlemi yapabiliyorum.
bunu makro ile yapabilme şansımız varmı

CEVAP

Merhaba,

Bu şekilde deneyin.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub BulTopla()

Dim Ss As Worksheet, c As Range, i As Long, Adr As String

Set Ss = Sheets("satış")

Application.ScreenUpdating = False
Sheets("yaşlandırma").Select
Range("H3:H" & Rows.Count).ClearContents

For i = 3 To Cells(Rows.Count, "E").End(xlUp).Row
With Ss.Range("E:E")
Set c = .Find(Cells(i, "E"), , xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
If Ss.Cells(c.Row, "A") = Range("H2") Then
Cells(i, "H") = Cells(i, "H") + Ss.Cells(c.Row, "K")
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
Next i

Application.ScreenUpdating = True

End Sub
 
. . .

Kod: 
Sub KOD()
    Application.ScreenUpdating = False
    Dim SV As Worksheet: Set SV = Sheets("Veri")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
    
    ST.Range("A2:D" & Rows.Count).ClearContents
    sat = 2
    For i = 2 To SV.Cells(Rows.Count, "B").End(3).Row
        If WorksheetFunction.CountIf(SV.Range("B2:B" & i), SV.Cells(i, "B")) = 1 Then
            ST.Cells(sat, "A") = SV.Cells(i, "B")
            ST.Cells(sat, "B") = SV.Cells(i, "C")
            ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("E:E"))
            ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("F:F"))
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

. . .
 
Teşekkürler Hüseyin Bey, ellerinize sağlık. İstediğim gibi olmuş.
 
Hüseyin Beu merhaba,

Yazdığınız kodla ilgili bir sorum olacak. Kod anladığım kadarı ile veri sayfasındaki Ürün Kodu sütunu verilerini benzersiz değerlere dönüştürüp ondan sonra toplama işlemini yaptırmakta. Düşündüğüm gibiyse bu benzersiz değerlere dönüştüren kodun nerde yazdığını anlamış değilim.

Ya da kodun çalışma mantığını kısaca açıklayabilir misiniz.

Teşekkürler,
 
"For...." ile başlayan satırın altındaki sorgu satırı benzersiz liste oluşmasını sağlıyor. Döngüye alınan veriler saydırılıyor. Sayım sonucu 1 ise işleme devam ediliyor.
 
Teşekkürler Korhan Bey,
 
. . .

Açıklamasını hazırlamıştım ancak şirket bilgisayarımda kalmıştı.

Şimdi yayınlayabiliyorum.

Kod: 
Sub KOD()
    Application.ScreenUpdating = False
  [COLOR="Green"]  ' ekran haraketlerini dondur[/COLOR]
    
    Dim SV As Worksheet: Set SV = Sheets("Veri")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
[COLOR="Green"]    'sayfa isimlerine değişken atama[/COLOR]
    
    ST.Range("A2:D" & Rows.Count).ClearContents
[COLOR="Green"]    'tablo sayfasını temizle[/COLOR]
    
    sat = 2
[COLOR="Green"]    'tablo sayfasında başlangıç satırımız[/COLOR]
    
    For i = 2 To SV.Cells(Rows.Count, "B").End(3).Row [COLOR="Green"]'(döngü)[/COLOR]
[COLOR="Green"]    'veri sayfası B sütununda 2.satırdan son dolu satıra kadar kontrol başlıyor[/COLOR]
    
        If WorksheetFunction.CountIf(SV.Range("B2:B" & i), SV.Cells(i, "B")) = 1 Then
[COLOR="Green"]        ' veri sayfasında B2:B2 - B2:B3 - B2:B4 diye devam ederek
        ' sırayla ürün kodlarını kontrol ediyoruz. ilk kez geçen ürün kodunu alıyoruz. (eğersay=CountIf)
        ' bu şekilde teke düşürüyoruz[/COLOR]
        
            ST.Cells(sat, "A") = SV.Cells(i, "B")
    [COLOR="Green"]        ' ilk önce bulunan ürün kodunu tablo sayfasına alıyoruz[/COLOR]
            
            ST.Cells(sat, "B") = SV.Cells(i, "C")
   [COLOR="Green"]         ' ürün ismini alıyoruz[/COLOR]
            
            ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("E:E"))
[COLOR="Green"]            'SumIf - Etopla Ürünün miktar toplamını aldırıyoruz[/COLOR]
            
            ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("F:F"))
  [COLOR="Green"]          ' ürünün tutar toplamını aldırıyoruz[/COLOR]
            
            sat = sat + 1
    [COLOR="Green"]        ' tablo sayfasında bir sonraki üründe bir alt satıra geçmesini sağlıyoruz[/COLOR]
            
        End If
   [COLOR="Green"]     ' eğersay şartı bitiyor[/COLOR]
        
    Next i
[COLOR="Green"]    ' döngü sonu[/COLOR]
    
    
    Application.ScreenUpdating = True
[COLOR="Green"]    ' ekran haraketlerini aç[/COLOR]
    
    MsgBox " B i t t i "
[COLOR="Green"]    ' uyarı[/COLOR]
End Sub

. . .
 
Hüseyin bey çok teşekkürler, şahsım adıma çok iyi bir uygulama görmüş oldum.
 
Merhaba,

Daha önce açtığım bu konu ile ilgili ek bir sorum olacak. İlgili örnek dosyanın miktar ve tutar sütunlarının altına dip toplamı nasıl aldırabilirim , makro ile. Bir de mümkünse alt toplam oluşturmak istiyorum.
 
. . .

Next i satırının altına şu kodları ilave ederek deneyiniz.

Kod: 
    ST.Cells(sat, "C") = WorksheetFunction.Sum(ST.Range("C2:C" & sat))
    ST.Cells(sat, "D") = WorksheetFunction.Sum(ST.Range("D2:D" & sat))

. . .
 
Hüseyin Çoban' Alıntı:
. . .

Açıklamasını hazırlamıştım ancak şirket bilgisayarımda kalmıştı.

Şimdi yayınlayabiliyorum.

Kod: 
Sub KOD()
    Application.ScreenUpdating = False
  [COLOR="Green"]  ' ekran haraketlerini dondur[/COLOR]
    
    Dim SV As Worksheet: Set SV = Sheets("Veri")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
[COLOR="Green"]    'sayfa isimlerine değişken atama[/COLOR]
    
    ST.Range("A2:D" & Rows.Count).ClearContents
[COLOR="Green"]    'tablo sayfasını temizle[/COLOR]
    
    sat = 2
[COLOR="Green"]    'tablo sayfasında başlangıç satırımız[/COLOR]
    
    For i = 2 To SV.Cells(Rows.Count, "B").End(3).Row [COLOR="Green"]'(döngü)[/COLOR]
[COLOR="Green"]    'veri sayfası B sütununda 2.satırdan son dolu satıra kadar kontrol başlıyor[/COLOR]
    
        If WorksheetFunction.CountIf(SV.Range("B2:B" & i), SV.Cells(i, "B")) = 1 Then
[COLOR="Green"]        ' veri sayfasında B2:B2 - B2:B3 - B2:B4 diye devam ederek
        ' sırayla ürün kodlarını kontrol ediyoruz. ilk kez geçen ürün kodunu alıyoruz. (eğersay=CountIf)
        ' bu şekilde teke düşürüyoruz[/COLOR]
        
            ST.Cells(sat, "A") = SV.Cells(i, "B")
    [COLOR="Green"]        ' ilk önce bulunan ürün kodunu tablo sayfasına alıyoruz[/COLOR]
            
            ST.Cells(sat, "B") = SV.Cells(i, "C")
   [COLOR="Green"]         ' ürün ismini alıyoruz[/COLOR]
            
            ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("E:E"))
[COLOR="Green"]            'SumIf - Etopla Ürünün miktar toplamını aldırıyoruz[/COLOR]
            
            ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("F:F"))
  [COLOR="Green"]          ' ürünün tutar toplamını aldırıyoruz[/COLOR]
            
            sat = sat + 1
    [COLOR="Green"]        ' tablo sayfasında bir sonraki üründe bir alt satıra geçmesini sağlıyoruz[/COLOR]
            
        End If
   [COLOR="Green"]     ' eğersay şartı bitiyor[/COLOR]
        
    Next i
[COLOR="Green"]    ' döngü sonu[/COLOR]
    
    
    Application.ScreenUpdating = True
[COLOR="Green"]    ' ekran haraketlerini aç[/COLOR]
    
    MsgBox " B i t t i "
[COLOR="Green"]    ' uyarı[/COLOR]
End Sub

. . .
Genişletmek için tıkla ...

Hüseyin Bey merhaba,

Yazmış olduğunuz kodu kendime ait bir çalışmaya uyarlamaya çalışmaktayım. Şöylesi bir çözüm bulmam gerekli. Ürün kodu ile ilgili satırlarda boş hücrelerin olduğunu varsayarsak kod bu satırları dikkate almamalı, atlamalı. Boş satırları şu hali ile dikkate almakta. Buna bir uyarlama yapabilir miyiz.
 
. . .

Kod: 
Sub KOD()
    Application.ScreenUpdating = False
    
    Dim SV As Worksheet: Set SV = Sheets("Veri")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
    
    ST.Range("A2:D" & Rows.Count).ClearContents
    
    sat = 2
    For i = 2 To SV.Cells(Rows.Count, "B").End(3).Row
[B][COLOR="Blue"]        If SV.Cells(i, "B") <> "" Then[/COLOR][/B]
            If WorksheetFunction.CountIf(SV.Range("B2:B" & i), SV.Cells(i, "B")) = 1 Then
                ST.Cells(sat, "A") = SV.Cells(i, "B")
                ST.Cells(sat, "B") = SV.Cells(i, "C")
                ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("E:E"))
                ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("F:F"))
                sat = sat + 1
            End If
[B][COLOR="Blue"]        End If[/COLOR][/B]
    Next i
    
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

. . .
 
İyi Akşamlar Hüseyin bey,

Çoketopla ile girdiğim formüller yavaşlamaya yol açtı, bana bu konuda aşağıdaki çoketopla yı makro ile yazmanız mümkün müdür. Yardımlarınız için şimdiden teşekkür ederim.

=ÇOKETOPLA('DATA-1'!$I:$I;'DATA-1'!$G:$G;TABLO!$C$4;'DATA-1'!$B:$B;TABLO!$B$8;'DATA-1'!$A:$A;TABLO!$A:$A)


iyi akşamlar.
 
Merhaba Hüseyin Bey,
Yukarıdaki makro örneğinde, B sütunundan sadece bir tanesini çekmek için tablo sayfasında hücreye değer tanımlayıp bu kritere göre raporu nasıl çekebiliriz?
 
Emir Hüseyin Çoban' Alıntı:
. . .

Kod: 
Sub KOD()
    Application.ScreenUpdating = False
    
    Dim SV As Worksheet: Set SV = Sheets("Veri")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
    
    ST.Range("A2:D" & Rows.Count).ClearContents
    
    sat = 2
    For i = 2 To SV.Cells(Rows.Count, "B").End(3).Row
[B][COLOR="Blue"]        If SV.Cells(i, "B") <> "" Then[/COLOR][/B]
            If WorksheetFunction.CountIf(SV.Range("B2:B" & i), SV.Cells(i, "B")) = 1 Then
                ST.Cells(sat, "A") = SV.Cells(i, "B")
                ST.Cells(sat, "B") = SV.Cells(i, "C")
                ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("E:E"))
                ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("F:F"))
                sat = sat + 1
            End If
[B][COLOR="Blue"]        End If[/COLOR][/B]
    Next i
    
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

. . .
Genişletmek için tıkla ...

Emir hocam ayni makroyu 2 ayri veri sayfasiyla yapa bilirmiyiz , yani 2 ci veri sayfasi var orda ayni kosulla ordaki toplaminada G:G sutununa almam lazim
 
ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("B:B"), SV.Cells(i, "B"), SV.Range("F:F"))

kisaca bu formulden sonra SUTUNUNA VERI2 SAYFASINDA B SUTUNU TABLODAKI AA SUTUNUNA ESITSE VERI2 DEKI O VERININ TOPLAMINIDA G SUTUNUNA GETIRMESI LAZIM

ST.Cells(sat, "E") = WorksheetFunction.SumIf(SV2.Range("B:B"), SV.Cells(i, "B"), SV.Range("G:G"))
 
Merhabalar cevab verebilecek varmi acba?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst