Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ocak 2005 Perşembe

Same Record

'Module1

Sub Same_Record()
Dim i, y, a As Integer
a = WorksheetFunction.CountA(Range("A1:A65000"))
For i = 1 To a
For y = i + 1 To a
If Cells(i, 1).Value = Cells(y, 1) Then
Cells(i, 2).Value = "x"
Cells(y, 2).Value = "x"
End If
Next y
Next i
End Sub

10 Ocak 2005 Pazartesi

Query




'UserForm1

'AddTools on UserForm1: Label1, Label2,ListBox1, ListBox2, Label3, Label4, Label5, Label6, Image1, Label7
Option Explicit
Dim x As Double, Query As Double, Toplam As Double
Dim Bulunan As New Collection
Dim Hücre As Range
Dim Kayıt, Kayıt_Sayısı, Alan

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Query ..."
Kayıt_Sayısı = WorksheetFunction.CountA(Range("Sayfa1!A3:A65536"))
With ListBox1
.ColumnCount = 3
.ColumnWidths = "60;60;60"
End With
With ListBox2
.ColumnCount = 2
.ColumnWidths = "60;60"
End With
If (Kayıt_Sayısı > 0) Then
Toplam = 0
For x = 1 To Kayıt_Sayısı
ListBox1.AddItem Cells(x + 2, 1), (x - 1)
ListBox1.List((x - 1), 1) = Cells(x + 2, 2)
ListBox1.List((x - 1), 2) = Cells(x + 2, 3)
Toplam = Toplam + Cells(x + 2, 3).Value
Next x
Label1.Caption = VBA.Format(Toplam, "#,##0.00"): Toplam = 0
Alan = "Sayfa1!A3:A" & Kayıt_Sayısı + 2
For Each Hücre In Range(Alan)
Bulunan.Add Hücre.Value, VBA.CStr(Hücre.Value)
Next Hücre
On Error GoTo 0
x = 0
Range("Sayfa1!E3").Value = ""
For Each Kayıt In Bulunan
Range("Sayfa1!E3").Value = Kayıt
Alan = "Sayfa1!A2:C" & Kayıt_Sayısı + 2
Query = WorksheetFunction.DSum(Range(Alan), 3, Range("Sayfa1!E2:F3"))
ListBox2.AddItem Kayıt
ListBox2.List(x, 1) = Query
Toplam = Toplam + Query
x = x + 1
Next Kayıt
Label2.Caption = VBA.Format(Toplam, "#,##0.00")
End If
End Sub

1 Ocak 2005 Cumartesi

Do Contingent Format


'Module1

Option Explicit
Dim Hücre As Range
Dim Dur As Boolean

Sub ŞartaBağlıFormatYap() 'Do Contingent Format
On Error Resume Next
Dur = True
[A1] = 1: [B1] = 0
For Each Hücre In Range("C3:C17,D4:D6,E7:E9,F10:F12,G7:G9,H4:H6,I3:I5,J3:K17,M3:M14,N15:N16,O17:P17,Q15:R16,R3:S14")
With Hücre
.FormulaR1C1 = "=(RC[-1]*0.05)+RC[-1]"
.Font.Bold = True
.Font.Color = vbBlack
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Columns.AutoFit
.Rows.AutoFit
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=$A$1"
With .FormatConditions(1).Interior
.PatternColorIndex = 37
.Pattern = xlGray50
End With
.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=$B$1"
With .FormatConditions(2).Interior
.PatternColorIndex = 6
.Pattern = xlGray50
End With
End With
Next Hücre
Call ŞartaBağlıFormatTesti
End Sub
Sub ŞartaBağlıFormatTesti()
On Error Resume Next
If Dur = False Then Exit Sub
If [A1] = 0 Then [A1] = 1 Else [A1] = 0
If [B1] = 0 Then [B1] = 1 Else [B1] = 0
Application.OnTime Now + TimeValue("00:00:01"), "ŞartaBağlıFormatTesti"
End Sub

Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

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
Anadolu Üniversitesi Açık Öğretim Fakültesi