Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Ekim 2008 Cuma

To Consolidate Duplicate Records




'UserForm1

'Add Tools On UserForm1: ListBox1, CommandButton1, Label, Image1, Label2
Option Explicit
Dim Seçim As Variant
Dim i As Long, No As Long
Dim Bulunan As Range
Dim Hesaplanan As Double

Private Sub UserForm_Initialize()
On Error GoTo Hata
Me.Caption = "[PBİD®] To Consolidate Duplicate Records..."
Call BilgiGetir
Hata:
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
End Sub
Private Sub CommandButton1_Click()
On Error GoTo Hata
Durak1:
No = Cells(65536, 2).End(xlUp).Row
For i = 1 To No
Seçim = Cells(i, 2).Value
Hesaplanan = 0
Hesaplanan = Hesaplanan + Cells(i, 3).Value
If ((i + 1) > No) Then Exit For
For Each Bulunan In Range(Cells((i + 1), 2), Cells(No, 2))
If Seçim = Bulunan Then
Hesaplanan = Hesaplanan + VBA.Val(Bulunan.Offset(0, 1))
Bulunan.EntireRow.Delete
Application.Cells(i, 3).Value = Hesaplanan
GoTo Durak1
End If
Next Bulunan
Next i
Call BilgiGetir
Exit Sub
Hata:
End Sub
Sub BilgiGetir()
On Error GoTo Hata
Hesaplanan = 0
No = Cells(65536, 2).End(xlUp).Row
ReDim Hafıza(1 To No, 1 To 3)
For i = 1 To No
Hafıza(i, 1) = Cells(i, 1)
Hafıza(i, 2) = Cells(i, 1).Offset(0, 1)
Hafıza(i, 3) = Cells(i, 1).Offset(0, 2)
Hesaplanan = Hesaplanan + VBA.Val(Hafıza(i, 3))
Next
With ListBox1
.ColumnCount = 3
.ColumnWidths = "24;150;36"
.List() = Hafıza()
End With
Label1.Caption = Hesaplanan
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul