Makro vba Kod yazma

[yusufcam]

Herkese Merhaba İyi Çalışmalar yardıma ihtilacım var
Örnek bir excel çalışma kitabında ( TES.xls) 10 tane P sütununda "17701-1" var.
başka bir excel çalışma kitabında (2017.xls) EKİCİ sayfasında icmali var
icmal çalışma (2017.xls ) EKİCİ sayfasına 17701 1 kaç tane olduğunu karşısına P sütununa ( Araç sayısı ) yazar mı teşekkürler. Örnek ;ek

 

[yusufcam]

Yardımcı olacak kimse yokmu

 

[yusufcam]

Ben sadece Toplam aldıra biliyorum kaç tane olduğunu saydırıp toplamını aldıramadım

 

[askm]

Anlatım karışık olmamış mı sanki. Hangisindeki değerleri hangisinde görmek istiyorsunuz. Ve kriter ne olacak. Yani filtreleme neye göre yapacak.

 

[yusufcam]

Ekteki
tes,xls p sutununda aynı degerden kaç tane varsa sayacak
kaç tanaeyse toplamını, 2017.xls de p sütununa yazdırmak istiyorum.

 

[askm]

Asıl çalışmanızda 17701-1 değerinden başka olmuyor mu. Yani bunu bir kere saydırıp 2017.xls de p1 e yazdırmak yeterli olacak mı? Yoksa 2017.xls de E ve F sütunlarını birleştirip bu değerden kaçartane var bunları mı soruyorsunuz. Tes.xls de sadece bir çeşit örnek olduğu için soruyorum.
17701-1 leri sayıp P7 ye
17701-2 leri sayıp P8 e mi yazılacak.

 

[askm]

Sanırım istediğiniz aşağıdaki şekilde.

Option Explicit
Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf, i, k
Dim SonSatir
Dim SonSat
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim dosya_yeri, dosya
Dim Aranan As String
Dim Aralik As Range
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "EKICI"
SonSat = Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("A65536").End(xlUp).Row
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "TES.xls"
SayfaAdi = "Sayfa1"
Workbooks.Open (dosya_yeri & dosya)

SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row

For i = 7 To SonSat
    Aranan = Workbooks(aktif_Ktp).Sheets(Kayit_syf).Cells(i, "E") & "-" & Workbooks(aktif_Ktp).Sheets(Kayit_syf).Cells(i, "F")
     Workbooks(aktif_Ktp).Sheets(Kayit_syf).Cells(i, "P") = WorksheetFunction.CountIf(Workbooks(dosya).Sheets(SayfaAdi).Range("P2:P" & SonSatir), Aranan)
Next i
'Workbooks(dosya).Save
Workbooks(dosya).Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Aktarma işlemi tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub

 

[yusufcam]

17701-1 leri sayıp P7 ye
17701-2 leri sayıp P8 e mi yazılacak.
17760-1 leri sayıp P..... gibi

 

[yusufcam]

biraz dan dener dönerim size

 

[yusufcam]

Teşekkür ederim emeginize saglık tamamdır

 

[askm]

Rica ederim.