• DİKKAT

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

Bir hücredeki sayıya başka bir hücredeki sayıyı ekleme

Olabilir, kişiler sayfasında bu yazdığınız isimlere ait aylar yerine de sütun adları olacak sanırım. Bununla ilgili örnek eklerseniz düzenleyip eklerim.
 
Ömer' Alıntı:
Olabilir, kişiler sayfasında bu yazdığınız isimlere ait aylar yerine de sütun adları olacak sanırım. Bununla ilgili örnek eklerseniz düzenleyip eklerim.
Genişletmek için tıkla ...
bana öğretebilir misiniz makroları rica etsem daha sonradan başka sütünlar falan eklerim diye
 
Kapsamlı bir şey istediniz, makrolarla ilgili bir alt yapınız var mı, varsa kodları inceleyip takıldığınız yeri sorarsanız daha doğru olacaktır.
 
Sütun isimlerinde "Flash Disk" - "Ekran Kartı" kartı gibi iki kelimeden oluşan veriler var.

Kodlar isim sütununa girdiğiniz son kelimeye göre arama yapıyordu, bu şekilde son kelime sütun adlarıyla uyuşmaz.

En başından isim ile açıklamayı ayrı sütunlara yazalım dememdeki sebeplerden biride buydu. Buna bir çözüm bulunabilir fakat veri düzenine göre farklı sorunlarda çıkabilir. O yüzden doğru veri işleme hesaplamalar için önemlidir.

Hala aynı görüşteyseniz kodları aşağıdakilerle değiştirerek deneyiniz.
Kod: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)   
    
    Dim S1 As Worksheet, c As Range, sut As Byte, isim As String, k As Range
    Dim deg As String, deg1 As String, deg2 As String, s
        
    Set S1 = Sheets("Kişiler")
    
    If Target.Count > 1 Then Exit Sub
      
    If ActiveSheet.Name <> S1.Name Then
    
        If Intersect(Target, Range("B5:C" & Rows.Count)) Is Nothing Then Exit Sub
        If Target.Column = 3 And IsNumeric(Target) = False Or IsNumeric(Cells(Target.Row, "C")) = False Then Exit Sub
        If Cells(Target.Row, "B") = "" Then Exit Sub
        
        s = Split(Cells(Target.Row, "B"), " ")
        deg1 = s(UBound(s))
        deg2 = s(UBound(s) - 1) & " " & s(UBound(s))
  
        Set c = S1.Rows(3).Find(deg1, , xlValues, xlWhole)
        If Not c Is Nothing Then
            sut = c.Column
            deg = deg1
        Else
            Set k = S1.Rows(3).Find(deg2, , xlValues, xlWhole)
            If Not k Is Nothing Then
                sut = k.Column
                deg = deg2
            End If
        End If
        
        If sut = 0 Then
             MsgBox "İsmin Sonuna Yazılan Değer" & Chr(10) _
             & "Kişiler Sayfasında Bulunamadı", vbInformation
             Exit Sub
        End If
        
        isim = WorksheetFunction.Substitute(Cells(Target.Row, "B"), " " & deg, "")
          
        Application.EnableEvents = False
        Set c = S1.[A:A].Find(isim, , xlValues, xlWhole)
        If Not c Is Nothing Then
            S1.Cells(c.Row, sut) = S1.Cells(c.Row, sut) + Cells(Target.Row, "C")
        End If
        Application.EnableEvents = True
        
    End If
    
End Sub

.
 

Ekli dosyalar

Ömer' Alıntı:
Sütun isimlerinde "Flash Disk" - "Ekran Kartı" kartı gibi iki kelimeden oluşan veriler var.

Kodlar isim sütununa girdiğiniz son kelimeye göre arama yapıyordu, bu şekilde son kelime sütun adlarıyla uyuşmaz.

En başından isim ile açıklamayı ayrı sütunlara yazalım dememdeki sebeplerden biride buydu. Buna bir çözüm bulunabilir fakat veri düzenine göre farklı sorunlarda çıkabilir. O yüzden doğru veri işleme hesaplamalar için önemlidir.

Hala aynı görüşteyseniz kodları aşağıdakilerle değiştirerek deneyiniz.
Kod: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)  
   
    Dim S1 As Worksheet, c As Range, sut As Byte, isim As String, k As Range
    Dim deg As String, deg1 As String, deg2 As String, s
       
    Set S1 = Sheets("Kişiler")
   
    If Target.Count > 1 Then Exit Sub
     
    If ActiveSheet.Name <> S1.Name Then
   
        If Intersect(Target, Range("B5:C" & Rows.Count)) Is Nothing Then Exit Sub
        If Target.Column = 3 And IsNumeric(Target) = False Or IsNumeric(Cells(Target.Row, "C")) = False Then Exit Sub
        If Cells(Target.Row, "B") = "" Then Exit Sub
       
        s = Split(Cells(Target.Row, "B"), " ")
        deg1 = s(UBound(s))
        deg2 = s(UBound(s) - 1) & " " & s(UBound(s))
 
        Set c = S1.Rows(3).Find(deg1, , xlValues, xlWhole)
        If Not c Is Nothing Then
            sut = c.Column
            deg = deg1
        Else
            Set k = S1.Rows(3).Find(deg2, , xlValues, xlWhole)
            If Not k Is Nothing Then
                sut = k.Column
                deg = deg2
            End If
        End If
       
        If sut = 0 Then
             MsgBox "İsmin Sonuna Yazılan Değer" & Chr(10) _
             & "Kişiler Sayfasında Bulunamadı", vbInformation
             Exit Sub
        End If
       
        isim = WorksheetFunction.Substitute(Cells(Target.Row, "B"), " " & deg, "")
         
        Application.EnableEvents = False
        Set c = S1.[A:A].Find(isim, , xlValues, xlWhole)
        If Not c Is Nothing Then
            S1.Cells(c.Row, sut) = S1.Cells(c.Row, sut) + Cells(Target.Row, "C")
        End If
        Application.EnableEvents = True
       
    End If
   
End Sub

.
Genişletmek için tıkla ...
peki birleşik bir şekilde yazsam olur mu
 
Şuan verdiğim kodlar son boşluktan sonra olanı arıyor, bulamazsa son 2 kelimeye göre arıyor. Veri düzeni değişmeyecekse bu haliyle de işinizi görür.
 
Çok teşekkür ederim tam istediğim gibi olmuş kişiler sayfasında ne yazarsa onu buluyor ve orayı arttırıyor.
Mükemmelsiniz ilginiz için çok teşekkür ederim.
 
Rica ederim, güle güle kullanın.
 
Bu konuyla ilgili bilgim yok maalesef.

@Haluk Bey müsait olursa konuyu incelemesini rica edelim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst