Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Şubat 2007 Perşembe

To Prepare The Accounting Trial Balance Based On Daily Records



'UserForm1

'A) Normal Reference Add

'1 Visual Basıc For Applications;
'2 Microsoft Excel 11.0 Object Library
'3 Microsoft Forms 2.0 Object Library
'4 Microsoft Windows Common Controls 6.0 (SP6)
'5 OLE Automation
'6 Microsoft Office 11.0 Object Library
'7 Wicrosoft Office WebComponents 11.0
'B) Tools Add on UserForm1\
'1. Frame1
'2. Frame1\Image1, Label1, Label2
'3. Label3, Label4, Label5, Label6, Label7, Label8, Label9, Label10, Label11, Label12, Label13
'4. ListBox1

Option Explicit
Dim i As Single, ii As Single
Dim No As Double, BorçToplam As Double, AlacakToplam As Double, KalanToplam As Double
Dim Alan As Range, Hücre As Range
Dim HesapNo As New Collection, Anahtar As String
Dim TakasH1, TakasH2, TakasB1, TakasB2, TakasA1, TakasA2
Dim Eleman
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] To Prepare The Accounting Trial Balance Based On Daily Records"
Application.Visible = True
Application.VBE.MainWindow.Visible = False
Call VeriTabanıHazırlama
Call EkranDüzenle
Call MizanHazırlamak
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
With Me
.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2
End With
End Sub
Private Sub UserForm_Resize()

On Error Resume Next
With Me
.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2
End With
Call EkranDüzenle
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Application.Visible = True
End
End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me
.BackColor = &H80000016
With Frame1
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label3
.Caption = "Müşteri Adı"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 42
.Height = 18
.Width = 204
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label4
.Caption = "Borç Tutarı"
.SpecialEffect = fmSpecialEffectEtched
.Left = 210
.Top = 42
.Height = 18
.Width = 96
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label5
.Caption = "Alacak Tutarı"
.SpecialEffect = fmSpecialEffectEtched
.Left = 306
.Top = 42
.Height = 18
.Width = 96
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label6
.Caption = "Bakiye Tutar"
.SpecialEffect = fmSpecialEffectEtched
.Left = 402
.Top = 42
.Height = 18
.Width = 96
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label7
.Caption = " Kayıt Adet"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 288
.Height = 18
.Width = 54
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label8
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 60
.Top = 288
.Height = 18
.Width = 48
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label9
.Caption = " Müşteri Adet"
.SpecialEffect = fmSpecialEffectEtched
.Left = 108
.Top = 288
.Height = 18
.Width = 54
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label10
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 162
.Top = 288
.Height = 18
.Width = 48
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label11
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 210
.Top = 288
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label12
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 306
.Top = 288
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label13
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 402
.Top = 288
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With ListBox1
.Top = 60
.Left = 6
.Height = 227.3
.Width = 491.95
.ColumnCount = 4
.ColumnWidths = "204;96;96;96;12"
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
End With
End With
End With
End Sub
Sub MizanHazırlamak()
'To Prepare The Accounting Trial Balance

On Error Resume Next
No = Cells(65536, 1).End(xlUp).Row
Set Alan = Range("A2:A" & No)
ReDim Hesap(1 To No)
ReDim Borç(1 To No)
ReDim Alacak(1 To No)
No = 1
For Each Hücre In Alan
Anahtar = VBA.CStr(Hücre.Value)
HesapNo.Add Hücre.Value, Anahtar
If VBA.Err.Number = 0 Then
No = HesapNo.Count
Hesap(No) = Hücre.Value
Borç(No) = Hücre.Offset(0, 1)
Alacak(No) = Hücre.Offset(0, 2)
Else
No = Application.WorksheetFunction.Match(Hücre.Value, Hesap(), 0)
Borç(No) = Borç(No) + Hücre.Offset(0, 1).Value
Alacak(No) = Alacak(No) + Hücre.Offset(0, 2).Value
End If
VBA.Err.Number = 0
Next Hücre
On Error GoTo 0
For i = 1 To (HesapNo.Count - 1)
For ii = (i + 1) To HesapNo.Count
If Hesap(i) > Hesap(ii) Then
TakasH1 = Hesap(i)
TakasH2 = Hesap(ii)
TakasB1 = Borç(i)
TakasB2 = Borç(ii)
TakasA1 = Alacak(i)
TakasA2 = Alacak(ii)
Hesap(ii) = TakasH1
Borç(ii) = TakasB1
Alacak(ii) = TakasA1
Hesap(i) = TakasH2
Borç(i) = TakasB2
Alacak(i) = TakasA2
End If
Next ii
Next i
No = 0: BorçToplam = 0: AlacakToplam = 0: KalanToplam = 0
For Each Eleman In HesapNo
UserForm1.ListBox1.AddItem Eleman
ListBox1.List(No, 1) = Borç(No + 1)
BorçToplam = BorçToplam + Borç(No + 1)
ListBox1.List(No, 2) = Alacak(No + 1)
AlacakToplam = AlacakToplam + Alacak(No + 1)
ListBox1.List(No, 3) = Borç(No + 1) - Alacak(No + 1)
KalanToplam = KalanToplam + (Borç(No + 1) - Alacak(No + 1))
No = No + 1
Next Eleman
Label8.Caption = Alan.Count
Label10.Caption = HesapNo.Count
Label11 = VBA.Format(BorçToplam, "###,##0.00"): Range("F" & HesapNo.Count + 2) = VBA.CCur(BorçToplam)
Label12 = VBA.Format(AlacakToplam, "###,##0.00"): Range("G" & HesapNo.Count + 2) = VBA.CCur(AlacakToplam)
Label13 = VBA.Format(KalanToplam, "###,##0.00"): Range("H" & HesapNo.Count + 2) = VBA.CCur(KalanToplam)
Range("E2:H" & HesapNo.Count + 1).Value = ListBox1.List()
With Range("E" & HesapNo.Count + 2 & ":H" & HesapNo.Count + 2)
.Cells(1, 1) = "Toplam"
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Font.ColorIndex = 2
End With
End Sub
Sub VeriTabanıHazırlama()
'To prepare the data base

On Error Resume Next
Cells.Delete Shift:=xlUp
Range("A1").FormulaR1C1 = "Müşteri No"
Range("B1").FormulaR1C1 = "Borç"
Range("C1").FormulaR1C1 = "Alacak"
Range("D1").FormulaR1C1 = "Kalan"
With Range("A1:D1")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:A").ColumnWidth = 24
Columns("B:D").ColumnWidth = 12
Range("A1:D1").Copy
Range("E1:H1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
Columns("E:E").ColumnWidth = 24
Columns("F:G").ColumnWidth = 12
Range("A2").Select
For i = 1 To 20
For ii = 1 To 36
Cells(((i - 1) * 36) + ii + 1, 1) = "Müşteri " & ii
Cells(((i - 1) * 36) + ii + 1, 2) = VBA.CCur(VBA.Rnd * 30)
Cells(((i - 1) * 36) + ii + 1, 3) = VBA.CCur(VBA.Rnd * 10)
Cells(((i - 1) * 36) + ii + 1, 4) = Cells(((i - 1) * 36) + ii + 1, 2) - Cells(((i - 1) * 36) + ii + 1, 3)
Next ii
Next i
With Range("A1:H1")
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Font.ColorIndex = 2
End With
End Sub

'Module

Sub FormAç()
On Error Resume Next
UserForm1.Show 0
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