eşit hücreleri biraraya olmayanları bir yana toplamak

K

kenanucler

Katılım
5 Nisan 2010
Mesajlar
13
Excel Vers. ve Dili
office 2003 TR
merhabalar forumu takip etmekteyim ve konyada muhasebecilik yapmaktayım.
bi türlü yapamadığım bi şey var ekteki örnek liste de isim az ama, bu isimlerin binlercesini eşitleyinceye kadara canım çıkıyor :)
Eğer yardımcı olursanız çok sevinirim. Şimdiden çok teşekkür ederim.
 

Ekli dosyalar

F

Ferhat Pazarçevirdi

Özel Üye
Katılım
15 Haziran 2006
Mesajlar
3,704
Excel Vers. ve Dili
Excel 2003, 2007, 2010 (TR)
Merhabalar,

Ekteki dosyayı inceleyiniz. Aşağıdaki kodlama yapılmıştır. Kodları kendi projenize adapte ederken, "Microsoft Activex Data Object Recordset xx" referansını eklemeyi unutmayınız.


Kod: 
Sub Sirala_ve_Esitle()
    
    Dim rs As ADOR.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim lRow As Long
    Dim lCol As Long
    Dim sAdSoyad As String
    Dim rngLst As Range
    Dim rngHcr As Range
    
    Set rs = New ADOR.Recordset
    
    With rs
        With .Fields
            .Append "AdSoyad", adChar, 100
            .Append "Rakam", adDouble
            .Append "ListeNo", adInteger
        End With
        
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .Open
        
        For i = 1 To 2
            If i = 1 Then
                Set rngLst = Range("C3:D" & Cells(65536, 3).End(xlUp).Row)
            Else
                Set rngLst = Range("F3:G" & Cells(65536, 6).End(xlUp).Row)
            End If
            
            For Each rngHcr In rngLst.Cells
                x = x + 1
                If x = 1 Then
                    .AddNew
                    .Fields("AdSoyad").Value = rngHcr.Value
                Else
                    .Fields("Rakam").Value = rngHcr.Value
                    .Fields("ListeNo").Value = i
                    x = 0
                End If
            Next
        Next i
        .Sort = "[AdSoyad], [ListeNo]"
    End With

    Range("I3:M5000").ClearContents
    lRow = 2
    Do Until rs.EOF
        If sAdSoyad = rs("AdSoyad") Then
            lCol = 12
        Else
            If rs("ListeNo") = 1 Then
                lCol = 9
            Else
                lCol = 12
            End If
            lRow = lRow + 1

        End If
        Cells(lRow, lCol) = Trim(rs("AdSoyad"))
        Cells(lRow, lCol + 1) = rs("Rakam")
        sAdSoyad = rs("AdSoyad")
        rs.MoveNext
    Loop
    Set rs = Nothing
End Sub
 

Ekli dosyalar

K

kenanucler

Katılım
5 Nisan 2010
Mesajlar
13
Excel Vers. ve Dili
office 2003 TR
Ferhat Pazarçevirdi' Alıntı:
Merhabalar,

Ekteki dosyayı inceleyiniz. Aşağıdaki kodlama yapılmıştır. Kodları kendi projenize adapte ederken, "Microsoft Activex Data Object Recordset xx" referansını eklemeyi unutmayınız.


Kod: 
Sub Sirala_ve_Esitle()
    
    Dim rs As ADOR.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim lRow As Long
    Dim lCol As Long
    Dim sAdSoyad As String
    Dim rngLst As Range
    Dim rngHcr As Range
    
    Set rs = New ADOR.Recordset
    
    With rs
        With .Fields
            .Append "AdSoyad", adChar, 100
            .Append "Rakam", adDouble
            .Append "ListeNo", adInteger
        End With
        
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .Open
        
        For i = 1 To 2
            If i = 1 Then
                Set rngLst = Range("C3:D" & Cells(65536, 3).End(xlUp).Row)
            Else
                Set rngLst = Range("F3:G" & Cells(65536, 6).End(xlUp).Row)
            End If
            
            For Each rngHcr In rngLst.Cells
                x = x + 1
                If x = 1 Then
                    .AddNew
                    .Fields("AdSoyad").Value = rngHcr.Value
                Else
                    .Fields("Rakam").Value = rngHcr.Value
                    .Fields("ListeNo").Value = i
                    x = 0
                End If
            Next
        Next i
        .Sort = "[AdSoyad], [ListeNo]"
    End With

    Range("I3:M5000").ClearContents
    lRow = 2
    Do Until rs.EOF
        If sAdSoyad = rs("AdSoyad") Then
            lCol = 12
        Else
            If rs("ListeNo") = 1 Then
                lCol = 9
            Else
                lCol = 12
            End If
            lRow = lRow + 1

        End If
        Cells(lRow, lCol) = Trim(rs("AdSoyad"))
        Cells(lRow, lCol + 1) = rs("Rakam")
        sAdSoyad = rs("AdSoyad")
        rs.MoveNext
    Loop
    Set rs = Nothing
End Sub
Genişletmek için tıkla ...
hay allah razı olsun. Çok teşekkür ederim. ferhat kardeşim her bu işi yaptığımda sana dua edeceğim inşallah. yalnız rakam olmasa da sıralasa çok hoş olacak. Örneği yüklüyorum. Olursa olmazsa sağlık olsun. Tekrar tekrar teşekkür ediyorum.:redface:
 

Ekli dosyalar

F

Ferhat Pazarçevirdi

Özel Üye
Katılım
15 Haziran 2006
Mesajlar
3,704
Excel Vers. ve Dili
Excel 2003, 2007, 2010 (TR)
Tamam, şimdi anladım ...

İlkönce kodlarda (başlarda) şu satırı bulun ...
Kod: 
.Append "Rakam", adDouble
Şu şekilde değiştiriniz.
Kod: 
.Append "Rakam", adChar, 100
Sonra da şu satırı (sonlara doğru) bulunuz ..
Kod: 
Cells(lRow, lCol + 1) = rs("Rakam")
ve şu şekilde değiştiriniz.
Kod: 
Cells(lRow, lCol + 1) = Trim(rs("Rakam"))

.
 
K

kenanucler

Katılım
5 Nisan 2010
Mesajlar
13
Excel Vers. ve Dili
office 2003 TR
ferhat pazarçevirdi' Alıntı:
tamam, şimdi anladım ...

Ilkönce kodlarda (başlarda) şu satırı bulun ...
Kod: 
.append "rakam", addouble
şu şekilde değiştiriniz.
Kod: 
.append "rakam", adchar, 100
sonra da şu satırı (sonlara doğru) bulunuz ..
Kod: 
cells(lrow, lcol + 1) = rs("rakam")
ve şu şekilde değiştiriniz.
Kod: 
cells(lrow, lcol + 1) = trim(rs("rakam"))

.
Genişletmek için tıkla ...
dediğinizi yaptım işe yaradı.
çok teşekkür ederim ferhat kardeşim.
Allah razı olsun. Kolay gelsin.
 
F

Ferhat Pazarçevirdi

Özel Üye
Katılım
15 Haziran 2006
Mesajlar
3,704
Excel Vers. ve Dili
Excel 2003, 2007, 2010 (TR)
kenanucler' Alıntı:
ferhat kardeşim son bi iyilik daha istiyorum sizden,örnek dosyaya bi bakarsanız çok sevineceğim.
Genişletmek için tıkla ...
Bunun için aşağıdaki kodları kullanınız.

Kod: 
Sub Sirala_ve_Esitle()
    
    Dim rs As ADOR.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim lRow As Long
    Dim lCol As Long
    Dim sAdSoyad As String
    Dim rngLst As Range
    Dim rngHcr As Range
    
    
    Set rs = New ADOR.Recordset
    
    With rs
        With .Fields
            .Append "AdSoyad", adChar, 100
            .Append "Rakam", adDouble
            .Append "ListeNo", adInteger
            .Append "Ciftmi", adBoolean
        End With
        
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .Open
        
        For i = 1 To 2
            If i = 1 Then
                Set rngLst = Range("C3:D" & Cells(65536, 3).End(xlUp).Row)
            Else
                Set rngLst = Range("F3:G" & Cells(65536, 6).End(xlUp).Row)
            End If
            
            For Each rngHcr In rngLst.Cells
                x = x + 1
                If x = 1 Then
                    .AddNew
                    .Fields("AdSoyad").Value = rngHcr.Value
                Else
                    .Fields("Rakam").Value = rngHcr.Value
                    .Fields("ListeNo").Value = i
                    x = 0
                End If
            Next
        Next i
        .Sort = "[AdSoyad], [ListeNo]"
    End With

    Do Until rs.EOF
        If sAdSoyad = rs("AdSoyad") Then
            rs("Ciftmi") = True
            rs.MovePrevious
            rs("Ciftmi") = True
            rs.MoveNext
        Else
            rs("Ciftmi") = False
        End If
        sAdSoyad = rs("AdSoyad")
        rs.MoveNext
    Loop
    
    Range("I3:M5000").ClearContents
    lRow = 2
    
    For i = 1 To 2
        rs.Filter = ""
        If i = 1 Then
            rs.Filter = "Ciftmi=True"
        Else
            rs.Filter = "Ciftmi=False"
        End If
        rs.MoveFirst
        Do Until rs.EOF
            If sAdSoyad = rs("AdSoyad") Then
                lCol = 12
            Else
                If rs("ListeNo") = 1 Then
                    lCol = 9
                Else
                    lCol = 12
                End If
                lRow = lRow + 1
    
            End If
            
            Cells(lRow, lCol) = Trim(rs("AdSoyad"))
            Cells(lRow, lCol + 1) = rs("Rakam")
            sAdSoyad = rs("AdSoyad")
            rs.MoveNext
            
        Loop
    Next i
    Set rs = Nothing
End Sub
.
 
K

kenanucler

Katılım
5 Nisan 2010
Mesajlar
13
Excel Vers. ve Dili
office 2003 TR
Ferhat Pazarçevirdi' Alıntı:
Bunun için aşağıdaki kodları kullanınız.

Kod: 
Sub Sirala_ve_Esitle()
    
    Dim rs As ADOR.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim lRow As Long
    Dim lCol As Long
    Dim sAdSoyad As String
    Dim rngLst As Range
    Dim rngHcr As Range
    
    
    Set rs = New ADOR.Recordset
    
    With rs
        With .Fields
            .Append "AdSoyad", adChar, 100
            .Append "Rakam", adDouble
            .Append "ListeNo", adInteger
            .Append "Ciftmi", adBoolean
        End With
        
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .Open
        
        For i = 1 To 2
            If i = 1 Then
                Set rngLst = Range("C3:D" & Cells(65536, 3).End(xlUp).Row)
            Else
                Set rngLst = Range("F3:G" & Cells(65536, 6).End(xlUp).Row)
            End If
            
            For Each rngHcr In rngLst.Cells
                x = x + 1
                If x = 1 Then
                    .AddNew
                    .Fields("AdSoyad").Value = rngHcr.Value
                Else
                    .Fields("Rakam").Value = rngHcr.Value
                    .Fields("ListeNo").Value = i
                    x = 0
                End If
            Next
        Next i
        .Sort = "[AdSoyad], [ListeNo]"
    End With

    Do Until rs.EOF
        If sAdSoyad = rs("AdSoyad") Then
            rs("Ciftmi") = True
            rs.MovePrevious
            rs("Ciftmi") = True
            rs.MoveNext
        Else
            rs("Ciftmi") = False
        End If
        sAdSoyad = rs("AdSoyad")
        rs.MoveNext
    Loop
    
    Range("I3:M5000").ClearContents
    lRow = 2
    
    For i = 1 To 2
        rs.Filter = ""
        If i = 1 Then
            rs.Filter = "Ciftmi=True"
        Else
            rs.Filter = "Ciftmi=False"
        End If
        rs.MoveFirst
        Do Until rs.EOF
            If sAdSoyad = rs("AdSoyad") Then
                lCol = 12
            Else
                If rs("ListeNo") = 1 Then
                    lCol = 9
                Else
                    lCol = 12
                End If
                lRow = lRow + 1
    
            End If
            
            Cells(lRow, lCol) = Trim(rs("AdSoyad"))
            Cells(lRow, lCol + 1) = rs("Rakam")
            sAdSoyad = rs("AdSoyad")
            rs.MoveNext
            
        Loop
    Next i
    Set rs = Nothing
End Sub
.
Genişletmek için tıkla ...
ya ben beceremedim bi hata veriyor ama çözemedim. örnek dosyaya yapıştırdım ama hata veriyor.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Üst