Excel Hakkında Herşey

**INVENTOR** · 23-10-2010, 10:15

Örnekler kısmında yer alan değişkenlere ExcelSheet hücrelerinden değerler atanarak kare matris determinant hesabı yaptırılabilir..

Birbirini çağıran fonksiyonlara dikkat..

Tanımlamalar:

Kod:

Public Type MatNxN
a() As Double
Minor() As Double
Determinant As Double
CoFactor() As Double
Transpose() As Double
Inverse() As Double
End Type

Public Mat2x2 As MatNxN
Public Mat3x3 As MatNxN
Public Mat4x4 As MatNxN

Fonksiyonlar:

Kod:

Public Function DeterminantOf(SqrMatrix() As Double) As Double
Dim i As Integer
Dim j As Integer
Dim CalcTotal As Double
For i = 1 To 1
For j = 1 To UBound(SqrMatrix)
CalcTotal = CalcTotal + SqrMatrix(i, j) * (-1) ^ (i + j) * MinorOf(SqrMatrix, i, j)
Next j
Next i
DeterminantOf = CalcTotal
End Function

Public Function MinorOf(SqrMatrix() As Double, EntityRowID As Integer, EntityColID As Integer) As Double
If UBound(SqrMatrix) = 1 Then Exit Function
Dim SubMatrix() As Double
DetermineSubMatrix SqrMatrix, EntityRowID, EntityColID, SubMatrix
If UBound(SubMatrix) = 1 Then
MinorOf = SubMatrix(1, 1)
Else
MinorOf = DeterminantOf(SubMatrix)
End If
End Function

Public Sub DetermineSubMatrix(SqrMatrix() As Double, EntityRowID As Integer, EntityColID As Integer, SubMatrix() As Double)
Dim i As Integer
Dim j As Integer
Dim subI As Integer
Dim subJ As Integer
ReDim SubMatrix(1 To UBound(SqrMatrix) - 1, 1 To UBound(SqrMatrix) - 1)
subI = 1: subJ = 1
For i = 1 To UBound(SqrMatrix)
If i = EntityRowID Then i = i + 1
For j = 1 To UBound(SqrMatrix)
If j = EntityColID Then j = j + 1
SubMatrix(subI, subJ) = SqrMatrix(i, j)
subJ = subJ + 1
If subJ = UBound(SqrMatrix) Then Exit For
Next j
subI = subI + 1
subJ = 1
If subI = UBound(SqrMatrix) Then Exit For
Next i
End Sub

Public Sub GetTransposeAndInverse(CoFactor() As Double, Transpose() As Double, Inverse() As Double, Det As Double)
Dim i As Integer
Dim j As Integer

For i = 1 To UBound(CoFactor)
For j = UBound(CoFactor) To 1 Step -1
Transpose(j, i) = CoFactor(i, j)
Inverse(j, i) = Transpose(j, i) / Det
Next j
Next i

End Sub

Örnekler; kodlar istenildiği şekilde düzenlenebilir..

3x3

Kod:

Public Sub Main3x3()
Dim i As Integer
Dim j As Integer
With Mat3x3
ReDim .a(1 To 3, 1 To 3)
.a(1, 1) = 3: .a(1, 2) = 4: .a(1, 3) = 2
.a(2, 1) = 2: .a(2, 2) = 1: .a(2, 3) = 2
.a(3, 1) = 3: .a(3, 2) = 1: .a(3, 3) = 3
ReDim .Minor(1 To 3, 1 To 3)
ReDim .CoFactor(1 To 3, 1 To 3)
ReDim .Transpose(1 To 3, 1 To 3)
ReDim .Inverse(1 To 3, 1 To 3)
For i = 1 To 3
For j = 1 To 3
.Minor(i, j) = MinorOf(.a, i, j)
.CoFactor(i, j) = (-1) ^ (i + j) * .Minor(i, j)
Next j
Next i

.Determinant = DeterminantOf(.a)

GetTransposeAndInverse .CoFactor, .Transpose, .Inverse, .Determinant

Dim K(1 To 3) As Double
K(1) = 12: K(2) = 7: K(3) = 10
Dim X As Double
Dim Y As Double
Dim Z As Double
For i = 1 To 3
X = X + .Inverse(1, i) * K(i)
Y = Y + .Inverse(2, i) * K(i)
Z = Z + .Inverse(3, i) * K(i)
Next i
Debug.Print "X=" & X & " Y=" & Y & " Z=" & Z
End With
End Sub

4x4

Kod:

Public Sub Main4x4()
Dim i As Integer
Dim j As Integer
With Mat4x4
ReDim .a(1 To 4, 1 To 4)
.a(1, 1) = 3: .a(1, 2) = 4: .a(1, 3) = 2: .a(1, 4) = 2
.a(2, 1) = 2: .a(2, 2) = 1: .a(2, 3) = 2: .a(2, 4) = 2
.a(3, 1) = 3: .a(3, 2) = 1: .a(3, 3) = 3: .a(3, 4) = 2
.a(4, 1) = 2: .a(4, 2) = 1: .a(4, 3) = 2: .a(4, 4) = 3
ReDim .Minor(1 To 4, 1 To 4)
ReDim .CoFactor(1 To 4, 1 To 4)
ReDim .Transpose(1 To 4, 1 To 4)
ReDim .Inverse(1 To 4, 1 To 4)
For i = 1 To 4
For j = 1 To 4
.Minor(i, j) = MinorOf(.a, i, j)
.CoFactor(i, j) = (-1) ^ (i + j) * .Minor(i, j)
Next j
Next i

.Determinant = DeterminantOf(.a)

GetTransposeAndInverse .CoFactor, .Transpose, .Inverse, .Determinant
Dim K(1 To 4) As Double
K(1) = 10: K(2) = 5: K(3) = 8: K(4) = 4
Dim X As Double
Dim Y As Double
Dim Z As Double
Dim W As Double
For i = 1 To 4
X = X + .Inverse(1, i) * K(i)
Y = Y + .Inverse(2, i) * K(i)
Z = Z + .Inverse(3, i) * K(i)
W = W + .Inverse(4, i) * K(i)
Next i
Debug.Print "X=" & X & " Y=" & Y & " Z=" & Z & " W=" & W
End With
End Sub

**INVENTOR** · 23-10-2010, 10:42

Sayın tyuksel, kusura bakmazsan bir gönderim daha olacak, biraz yer kaplayan..

Bir blog açmıştım, oradaydı gönderilerim.. artık kullanamıyorum o blogu maalesef.

Direk Excel ile ilgili olmasa da kodlar Excel VBA içerisine adapte edilebilir.

VB6 için Bezier Eğrileri çizdirmeye yönelik bir uygulama..

Bezier Polinom formunda bir çalışma..

Exe dosya buradan .. http://www.mediafire.com/file/xtji4z...zierCurves.exe

Module içi Public tanımlamalar..

Kod:

Option Explicit

Public Type POINT_DEFINION
X As Double
Y As Double
End Type

Public ControlPointsArray() As POINT_DEFINION

Public DerivedPointsArray() As POINT_DEFINION

Public MaxYOfUser As Double
Public XAndYScale As Double
'

Faktöriyel hesabı yapan fonksiyon
Bezier eğrilerinin handikapı; polinomun derecesine bağımlısınız maalesef..

Onun için NURBS kullanmam lazım.. Burada kullanılan yöntem biraz kandırmaca.. Noktanın ağırlık faktörü önemli aslında, sıradışı noktaları kodun elimine edebilmesi lazım.. Dolayısıyla NURBS

Kod:

Public Function CalculateFactorial(n_ As Integer) As Long

If n_ < 0 Then
MsgBox "Trying to calculate factorial of negative number"
Exit Function
End If

If n_ = 0 Then
CalculateFactorial = 1
Exit Function
End If

Dim FxResult As Long

Static iCnt As Integer

FxResult = 1

On Error Resume Next

For iCnt = n_ To 1 Step -1
FxResult = FxResult * iCnt
Next iCnt

If Err.Number Then
MsgBox "Factorial calculation (overflow) Error Description :" & Err.Description
Err.Clear
Exit Function
End If

CalculateFactorial = FxResult

End Function

Rekürsif (kendi kendini çağıran anlamında) fonksiyon şeklinde faktöriyel hesabı:

Kod:

Public Function Factorial(AnyInteger As Integer) As Double

If AnyInteger = 0 Then
Factorial = 1#
Exit Function
End If

Factorial = CDbl(AnyInteger) * Factorial(AnyInteger - 1)

End Function

Bezier Eğrisi Hesabı

Kod:

'degree of polynom = n
'number of control points = n+1
'number of segments = NbrOfSegments

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''*
'' B(t)=Sigma{j=0 to n} t^j * Cj
'' Cj = (n!/(n-j)!) * Sigma{i=0 to j} [(-1)^(i+j) * Pi] / [i! * (j-i)!]

Public Sub CalculateBezier(PointsArray() As POINT_DEFINION, NbrOfSegments As Integer)

Dim n As Integer
n = UBound(PointsArray)

If n = 0 Then

MsgBox "1 adet nokta tanımlanmış"
Exit Sub

End If

Dim DerivedPointsQuantity As Long
DerivedPointsQuantity = NbrOfSegments * n

ReDim DerivedPointsArray(0 To DerivedPointsQuantity)

Dim t As Double

t = 0

Dim CalculatedBezierValueX As Double
Dim CalculatedBezierValueY As Double

Static j As Integer

Dim tCounter As Long
For tCounter = 0 To DerivedPointsQuantity

CalculatedBezierValueX = 0#
CalculatedBezierValueY = 0#

For j = 0 To n

CalculatedBezierValueX = CalculatedBezierValueX + t ^ j * CjFunctionX(n, j, PointsArray)
CalculatedBezierValueY = CalculatedBezierValueY + t ^ j * CjFunctionY(n, j, PointsArray)

Next j

DerivedPointsArray(tCounter).X = CalculatedBezierValueX
DerivedPointsArray(tCounter).Y = CalculatedBezierValueY

t = t + (1 / DerivedPointsQuantity)

Next tCounter

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''*
'' Cj = (n!/(n-j)!) * Sigma{i=0 to j} [(-1)^(i+j) * Pi] / [i! * (j-i)!]
'' Cj = (n!/(n-j)!) * SjFunction
'' SjFunction=Sigma{i=0 to j} [(-1)^(i+j) * Pi] / [i! * (j-i)!]

Public Function CjFunctionX(n As Integer, j As Integer, PointsArray() As POINT_DEFINION) As Double

Dim CalculatedFactorial As Long

CalculatedFactorial = CLng(CalculateFactorial(n) / CalculateFactorial(n - j))

Dim CalculatedSjFunction As Double

Static i As Integer

For i = 0 To j

CalculatedSjFunction = CalculatedSjFunction + SjFunctionX(j, i, PointsArray)

Next i

CjFunctionX = CalculatedFactorial * CalculatedSjFunction

End Function

Public Function CjFunctionY(n As Integer, j As Integer, PointsArray() As POINT_DEFINION) As Double

Dim CalculatedFactorial As Long

CalculatedFactorial = CLng(CalculateFactorial(n) / CalculateFactorial(n - j))

Dim CalculatedSjFunction As Double

Static i As Integer

For i = 0 To j

CalculatedSjFunction = CalculatedSjFunction + SjFunctionY(j, i, PointsArray)

Next i

CjFunctionY = CalculatedFactorial * CalculatedSjFunction

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''*
'' SjFunction=Sigma{i=0 to j} [(-1)^(i+j) * Pi] / [i! * (j-i)!]

Public Function SjFunctionX(j As Integer, i As Integer, PointsArray() As POINT_DEFINION) As Double

SjFunctionX = ((-1) ^ (i + j) * PointsArray(i).X) / (CalculateFactorial(i) * CalculateFactorial(j - i))

End Function

Public Function SjFunctionY(j As Integer, i As Integer, PointsArray() As POINT_DEFINION) As Double

SjFunctionY = ((-1) ^ (i + j) * PointsArray(i).Y) / (CalculateFactorial(i) * CalculateFactorial(j - i))

End Function

Form1 içine bi tane Picture1 nesnesi yerleştiriyoruz..

Kod:

Private Sub Form_Initialize()

MaxYOfUser = 10#
XAndYScale = Form1.Picture1.ScaleHeight / MaxYOfUser

MsgBox "Sol tuşa basarak noktalar belirleyin." & vbCr & "İkinci noktadan sonra Bezier eğrileri çizilecek." & vbCr & vbCr & "Grafiği temizlemek için sağ tuşa basın."

End Sub

Picture1 üzerinde tıklanan nokta koordinatlarını alıyoruz..

Kod:

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static ControlPointsCount As Integer
Static Bool_GraphStarted As Boolean
Static Bool_ThereIAreAtLeastTwoLines As Boolean
Static LastX As Single
Static LastY As Single

Dim Last2Points(1) As POINT_DEFINION

If Button = 1 And Not Bool_GraphStarted Then
Form1.Picture1.Circle (X, Y), XAndYScale * MaxYOfUser / 100#, vbYellow
LastX = X
LastY = Y
Bool_GraphStarted = True
ElseIf Button = 1 And Bool_GraphStarted Then
Form1.Picture1.Circle (X, Y), XAndYScale * MaxYOfUser / 100#, vbYellow

If ControlPointsCount = 0 Then
ReDim ControlPointsArray(2)

With ControlPointsArray(0)
.X = LastX / XAndYScale
.Y = (Form1.Picture1.ScaleHeight - LastY) / XAndYScale
End With

With ControlPointsArray(2)
.X = X / XAndYScale
.Y = (Form1.Picture1.ScaleHeight - Y) / XAndYScale
End With

With ControlPointsArray(1)
.X = (ControlPointsArray(0).X + ControlPointsArray(2).X) / 2#
.Y = (ControlPointsArray(0).Y + ControlPointsArray(2).Y) / 2#
End With

ControlPointsCount = 2

ElseIf ControlPointsCount = 2 And Not Bool_ThereIAreAtLeastTwoLines Then

ReDim Preserve ControlPointsArray(4)

With ControlPointsArray(4)
.X = X / XAndYScale
.Y = (Form1.Picture1.ScaleHeight - Y) / XAndYScale
End With

With ControlPointsArray(3)
.X = (ControlPointsArray(4).X + ControlPointsArray(2).X) / 2#
.Y = (ControlPointsArray(4).Y + ControlPointsArray(2).Y) / 2#
End With

Last2Points(1).X = ControlPointsArray(4).X
Last2Points(1).Y = ControlPointsArray(4).Y

Last2Points(0).X = ControlPointsArray(3).X
Last2Points(0).Y = ControlPointsArray(3).Y

ReDim Preserve ControlPointsArray(3)

DrawGraphData

ReDim ControlPointsArray(1)

ControlPointsArray(0).X = Last2Points(0).X
ControlPointsArray(0).Y = Last2Points(0).Y

ControlPointsArray(1).X = Last2Points(1).X
ControlPointsArray(1).Y = Last2Points(1).Y

ControlPointsCount = 2
Bool_ThereIAreAtLeastTwoLines = True

ElseIf ControlPointsCount = 2 And Bool_ThereIAreAtLeastTwoLines Then
ReDim Preserve ControlPointsArray(3)

With ControlPointsArray(3)
.X = X / XAndYScale
.Y = (Form1.Picture1.ScaleHeight - Y) / XAndYScale
End With

With ControlPointsArray(2)
.X = (ControlPointsArray(3).X + ControlPointsArray(1).X) / 2#
.Y = (ControlPointsArray(3).Y + ControlPointsArray(1).Y) / 2#
End With

Last2Points(1).X = ControlPointsArray(3).X
Last2Points(1).Y = ControlPointsArray(3).Y

Last2Points(0).X = ControlPointsArray(2).X
Last2Points(0).Y = ControlPointsArray(2).Y

ReDim Preserve ControlPointsArray(2)

DrawGraphData

ReDim ControlPointsArray(1)

ControlPointsArray(0).X = Last2Points(0).X
ControlPointsArray(0).Y = Last2Points(0).Y

ControlPointsArray(1).X = Last2Points(1).X
ControlPointsArray(1).Y = Last2Points(1).Y

ControlPointsCount = 2

End If

LastX = X
LastY = Y
ElseIf Button = 2 Then
Bool_GraphStarted = False
Bool_ThereIAreAtLeastTwoLines = False
LastX = 0#
LastY = 0#
ControlPointsCount = 0
Me.Picture1.Cls
End If

End Sub

Bezier eğrisini Picture1 üzerinde çizdiriyoruz..

Kod:

Private Sub DrawGraphData()

CalculateBezier ControlPointsArray, 4

Dim i As Integer

Dim GraphPoints() As POINT_DEFINION

''Bezier egrisi çizdiriliyor
ReDim GraphPoints(0 To UBound(DerivedPointsArray))

For i = 0 To UBound(DerivedPointsArray)

GraphPoints(i).X = DerivedPointsArray(i).X * XAndYScale
GraphPoints(i).Y = Form1.Picture1.ScaleHeight - DerivedPointsArray(i).Y * XAndYScale

Next i

Dim TrendColor As Long
For i = 1 To UBound(GraphPoints)

If GraphPoints(i - 1).Y >= GraphPoints(i).Y Then
TrendColor = vbGreen
Else
TrendColor = vbRed
End If

Form1.Picture1.Line (GraphPoints(i - 1).X, GraphPoints(i - 1).Y)-(GraphPoints(i).X, GraphPoints(i).Y), TrendColor

Next i
End Sub

**Erasure** · 23-10-2010, 12:53

Birilerinin mutlaka işine yarar, VBA'daki color index numaralarını ve renk kodlarını göndereyim.

**kemalcoban** · 23-10-2010, 19:32

Originally Posted by osmancig

müşterilerin aldığı ürünlerin listelenmesine ihtiyacım var.

"MÜŞTERİ VERİTABANI" sayfasındaki A3 hücresinden A13417 hücresine kadar girilmiş müşterilerin satın aldığı ürünler "SATIŞ & SENET" sayfasında E sutununda müşteri adı G sutununda ise aldığı ürün olarak girilmiş vaziyettedir. "MÜŞTERİ VERİTABANI" sayfasında K sutunundan sağa doğru aldığı ürünlerin her bir hücreye 1 adet ürün gelecek şekilde listelenmesini nasıl yapabilirim. Düşeyara fonksiyonunu (=DÜŞEYARA(A6;'SATIŞ & SENET'!E4:G40448;3;0) denedim ancak sadece ilk adığı ürünü listeletebildim.

"MÜŞTERİ VERİTABANI" sayfasında "müşteri 1", "müşteri 2" ve "müşteri 3" için manuel örnek yaptım.

dosyam biraz büyük olduğu için RapidShare de paylaştım linki:
http://rapidshare.com/files/426423216/soru.rar

link iptal olmuş yeni link yükledim
http://rapidshare.com/files/426744313/soru.rar

**tyuksel** · 23-10-2010, 21:51

Originally Posted by INVENTOR

Sayın tyuksel, kusura bakmazsan bir gönderim daha olacak, biraz yer kaplayan..

Bir blog açmıştım, oradaydı gönderilerim.. artık kullanamıyorum o blogu maalesef.

Direk Excel ile ilgili olmasa da kodlar Excel VBA içerisine adapte edilebilir.

Sn.Inventor güzel paylaşımlarınızın hepsini inceleme ve deneme fırsatım olmadı ama hepsi için ayrı ayrı teşekkürler...

Bu arada foruma hoşgeldiniz, sokaktakiadam'ı aratmayacağınızdan şüphem yok

**tyuksel** · 23-10-2010, 23:07

Originally Posted by osmancig

link iptal olmuş yeni link yükledim
http://rapidshare.com/files/426744313/soru.rar

Forum ilk açıldığında Sn.Venguvac benzer bir soru daha sormuştu ve şu şekilde çözmüştük.

Öncelikle her müşteri ve ürün için "müşteri 13146-1" gibi benzersiz bir kod oluşturmamız gerekiyor. Bunun için aşağıdaki formülü yazarak önce toplam alışveriş sayısını belirleyip sonra bulunduğumuz alışverişin bu listede kaçıncı olduğunu "EĞERSAY" formülüyle belirleyip ikinci resimdeki birleştirme formülüyle benzersiz kodu oluşturuyoruz. ($ işaretlerinin yeri bu şekilde sayma işlemi yapılan formüllerde çok önemli, onlara ayrıca dikkat edilmesi gerekir)

Ardından ilk sayfada da aynı benzersiz kodu aşağıdaki formülle oluşturacağız ve düşeyara'yı bu benzersiz kodlarla yapıp en alttaki şekilde ürünleri taşımış olacağız. (Eğer aynı sayfada hem benzersiz kodu oluşturmak hem de ürünleri taşımak excelin sütun sayısından fazla olacaksa benzersiz kodlar ayrı bir excel sayfasında oluşturulabilir.)

Listeniz çok geniş olduğundan bu şekilde yapmak sorununuzu çözer ama sistem kaynaklarını çok fazla kullanabilir. Belki bir macro ile daha etkili bir çözüm üretilebilir ama benim macro bilgim bunu yapmam için çok fazla uğraşmamı gerektireceğinden onu denemedim. Umarım bu formülasyonlar işinizi çözer.

**INVENTOR** · 24-10-2010, 01:18

Excel birçoğumuzun kullandığı bir uygulama. Hücre içi formülasyon ile hesaplamalar genelde bilinen bir yöntem.

- Excel içerisinde bütünleşik bir kullanıcı arabirimi vardır; VBA (Visual Basic Application)
- Bu arabirime makro yazılarak, kullanıcı formları eklenerek gelişmiş uygulamalar oluşturulabilir.
- Bu arabirime geçiş kısayolu Alt+F11 tuş kombinasyonudur.
- Excel içindeki bu arabirimde Visual Basic temelli kodlar kullanılır, bu kodlar ve kullanıcı formları Excel dosyanız içerisinde gömülü olarak kaydedilir ve de dosya ile birlikte açılır.

Basit Bir Örnek Çalışma

- Boş bir dosya açıyorum. Sayfaları aşağıdaki gibi düzenliyorum.

- İkinci sayfada bir buton (düğme) var.. üstteki toolbarı kullanarak sayfaya ekledim.

- Alt+F11 ile VBA arabirimine geçiş yapıyorum. Project - VBA Project penceresi içerisindeki boş alana sağ tıklayarak ya da menüleri kullanarak bir kullanıcı formu ekliyorum.

- Toolbox üzerindeki kontrolleri kullanarak kullanıcı formuna iki tane listbox, bir tane textbox ve bir tane CommandButton ekliyorum.

- Sayfa2 (SATIŞLAR) üzerine eklediğim düğme için bir sub yaratıp oluşturduğunuz kullanıcı formunu göstermesine yönelik kodu yazıyorum. Bunun için bu düğmeye sağ tıklayıp AssignMakro seçeneğini kullanarak oluşan Module içerisinde yer alan Sub Button1_Tıklat() makrosunu aşağıdaki gibi oluşturuyorum.

Kod:

Sub Button1_Tıklat()
    UserForm1.Show
End Sub

- SATIŞLAR sayfasında bulunan düğmeye tıkldığımda oluşturduğum kullanıcı formu ekrana geliyor.

Devam edecek...

Bölüm 2 için TIKLAYIN

**INVENTOR** · 24-10-2010, 03:56

Bu yazının öncesi.. Birinci Bölüm

Sadece UserForm1 içerisinden erişilebilen tanımlamaları yapıyoruz; bunlar Private olarak tanımlıdır..

Kod:

Const Str_SheetName_MainPage            As String = "AnaSayfa"
Const Str_SheetName_SalesData           As String = "SATISLAR"
''
Const Lng_RowStartID_InputData          As Long = 2 'AnaSayfa'da yer alan verilerin başlangıç satır numarası
Const Lng_ColID_InputData_Customers     As Long = 1 'AnaSayfa'da yer alan Müşteri bilgilerinin kolon numarası   (A Kolonu)
Const Lng_ColID_InputData_Products      As Long = 3 'AnaSayfa'da yer alan Ürünler bilgilerinin kolon numarası   (C Kolonu)
Const Lng_ColID_InputData_Stocks        As Long = 4 'AnaSayfa'da yer alan Stok bilgilerinin kolon numarası      (D Kolonu)
''
Const Lng_RowStartID_OutputData         As Long = 2 'SATIŞLAR'da yer alacak verilerin başlangıç satır numarası
Const Lng_ColID_OutputData_Customers    As Long = 1 'SATIŞLAR'da yer alan Müşteri bilgilerinin kolon numarası       (A Kolonu)
Const Lng_ColID_OutputData_Products     As Long = 2 'SATIŞLAR'da yer alan Aldığı Ürün bilgilerinin kolon numarası   (B Kolonu)
Const Lng_ColID_OutputData_Quantity     As Long = 3 'SATIŞLAR'da yer alan Miktar bilgilerinin kolon numarası        (C Kolonu)
Const Lng_ColID_OutputData_SalesDate    As Long = 4 'SATIŞLAR'da yer alan Tarih bilgilerinin kolon numarası         (D Kolonu)
''

Public; yani genel tanımlamalar; Module içerisinde yapılır, bu şekilde tanımlanmış değişkenlere farklı UserForm ve farklı Module içi makrolar tarafından erişilebilir.

UserForm1 ilk olarak çağrıldığında UserForm_Initialize() makrosu kendi kendine çalışır..
Sırasıyla içindeki satırları işletmeye başlar..

Kod:

Private Sub UserForm_Initialize()
    FillCustomersList
    FillProductsList
End Sub

Kod:

Sub FillCustomersList()
Static i As Long
    With ThisWorkbook.Sheets(Str_SheetName_MainPage)
        i = 0
        While .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Customers) <> ""
            Me.ListBox1.AddItem .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Customers)
            i = i + 1
        Wend
    End With
    Me.ListBox1.ListIndex = 0
End Sub

Kod:

Sub FillProductsList()
Dim ProductQuantity As Integer
Static i As Long
    With ThisWorkbook.Sheets(Str_SheetName_MainPage)
        i = 0
        While .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products) <> ""
            ProductQuantity = CInt(.Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Stocks))
            If ProductQuantity > 0 Then Me.ListBox2.AddItem .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products)
            i = i + 1
        Wend
    End With
    Me.ListBox2.ListIndex = 0
End Sub

Oluşturulan kullanıcı formunda bulunan CommandButton1 (KAYDET düğmesi) nesnesine tıklayınca CommandButton1_Click() makrosu otomatik olarak çalışır..

Kod:

Private Sub CommandButton1_Click()
Static i As Long
    If Trim(Me.TextBox1.Text) = "" Then
        MsgBox "Miktar Giriniz", vbExclamation + vbOKOnly
        Exit Sub
    ElseIf Not IsNumeric(Trim(Me.TextBox1.Text)) Then
        MsgBox "Sayısal Miktar Giriniz", vbExclamation + vbOKOnly
        Exit Sub
    End If
    
    If vbYes <> MsgBox("Müşteri ismi: " & Me.ListBox1.Text & vbCr & _
                        "Satılan ürün: " & Me.ListBox2.Text & vbCr & _
                        "Miktar: " & Trim(Me.TextBox1.Text) & vbCr & vbCr & _
                        "Satış işlemini onaylıyor musunuz?", vbQuestion + vbYesNo) Then Exit Sub

Dim QuantityInStocks As Long

    If CheckAvailableQuantity(Me.ListBox2.Text, CLng(Trim(Me.TextBox1.Text)), QuantityInStocks) Then
        With ThisWorkbook.Sheets(Str_SheetName_SalesData)
            .Activate
            i = 0
            While .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Customers) <> ""
                i = i + 1
            Wend
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Customers) = Me.ListBox1.Text
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Products) = Me.ListBox2.Text
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Quantity) = Me.TextBox1.Text
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_SalesDate) = Format(Now, "dd.mmmm.yyyy hh:mm:ss")
        End With
        MsgBox "Stoklarda " & QuantityInStocks & " adet ürün kalmıştır.", vbInformation + vbOKOnly
        Me.TextBox1.Text = ""
    Else
        MsgBox "Stoklarda " & QuantityInStocks & " adet ürün kalmıştır." & vbCr & "Satış miktarı olan " & _
            CLng(Trim(Me.TextBox1.Text)) & " adet ürün temin edilememektedir.", vbExclamation + vbOKOnly
    End If
    
End Sub

Burada diğer makrolardan farklı olarak bir fonksiyon yapısında kod mevcuttur..
Boolean (0-1 False-True) olarak değer dönüşü yapan bir fonksiyon.. fonksiyona dış parametre girişi yapılabilir, dikkat edilirse FinalQuantityOfProduct ile girilen parametre değişkene fonksiyon içinde yeni değer atanabilmektedir..

Kod:

Function CheckAvailableQuantity(ByVal SoldProductName As String, ByVal SoldQuantity As Long, FinalQuantityOfProduct As Long) As Boolean
Dim ProductName         As String
Dim ProductQuantity     As Integer
Static i As Long
    With ThisWorkbook.Sheets(Str_SheetName_MainPage)
        i = 0
        While .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products) <> ""
            ProductName = .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products)
            If ProductName = SoldProductName Then
                ProductQuantity = CInt(.Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Stocks))
                If ProductQuantity >= SoldQuantity Then
                    FinalQuantityOfProduct = ProductQuantity - SoldQuantity
                    .Activate
                    .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Stocks) = FinalQuantityOfProduct
                    CheckAvailableQuantity = True
                Else
                    FinalQuantityOfProduct = ProductQuantity
                End If
                Exit Function
            End If
            i = i + 1
        Wend
    End With
End Function

Oluşturduğumuz bu küçük örnek çalıştırılıp bir kaç satış işlemi gerçekleştiriyorum..
Müşteri seçiyorum, ürün seçiyorum, miktar giriyorum ve KAYDET düğmesine basıyorum..
SATIŞLAR sayfasındaki satırlar otomatik olarak düzenleniyor..

Formu kapatıp AnaSayfa'ya döndüğümde Stok kolonunda bulunan değerlerden yapılan satış işlemlerindeki miktar değerleri düşülmüş oluyor..

Programı çalıştırmadan önceki stok miktarları..

Bu Excel dosyasını buradan indirebilirsiniz..DOSYA MAKRO İÇERMEKTEDİR - TIKLAYIN

Bir slogan olarak;
Excel; VBA ile; Excel olmanın ötesindedir..

Küçük bir örnekti bu.. önemli olan balık tutmayı öğretmektir galiba, gerisi de biraz balık tutmaya istekli olmakta.

Not: Her ne kadar Excel programının Türkçe sürümünü de kullanıyor olsanız, Excel VBA öğrenebilmek için en az orta düzeyde İngilizce bilgisi gerekmektedir.

TÜM KODLAR TOPLU OLARAK:

Kod:

Option Explicit
''
Const Str_SheetName_MainPage            As String = "AnaSayfa"
Const Str_SheetName_SalesData           As String = "SATISLAR"
''
Const Lng_RowStartID_InputData          As Long = 2 'AnaSayfa'da yer alan verilerin başlangıç satır numarası
Const Lng_ColID_InputData_Customers     As Long = 1 'AnaSayfa'da yer alan Müşteri bilgilerinin kolon numarası   (A Kolonu)
Const Lng_ColID_InputData_Products      As Long = 3 'AnaSayfa'da yer alan Ürünler bilgilerinin kolon numarası   (C Kolonu)
Const Lng_ColID_InputData_Stocks        As Long = 4 'AnaSayfa'da yer alan Stok bilgilerinin kolon numarası      (D Kolonu)
''
Const Lng_RowStartID_OutputData         As Long = 2 'SATIŞLAR'da yer alacak verilerin başlangıç satır numarası
Const Lng_ColID_OutputData_Customers    As Long = 1 'SATIŞLAR'da yer alan Müşteri bilgilerinin kolon numarası       (A Kolonu)
Const Lng_ColID_OutputData_Products     As Long = 2 'SATIŞLAR'da yer alan Aldığı Ürün bilgilerinin kolon numarası   (B Kolonu)
Const Lng_ColID_OutputData_Quantity     As Long = 3 'SATIŞLAR'da yer alan Miktar bilgilerinin kolon numarası        (C Kolonu)
Const Lng_ColID_OutputData_SalesDate    As Long = 4 'SATIŞLAR'da yer alan Tarih bilgilerinin kolon numarası         (D Kolonu)
''

Private Sub CommandButton1_Click()
Static i As Long
    If Trim(Me.TextBox1.Text) = "" Then
        MsgBox "Miktar Giriniz", vbExclamation + vbOKOnly
        Exit Sub
    ElseIf Not IsNumeric(Trim(Me.TextBox1.Text)) Then
        MsgBox "Sayısal Miktar Giriniz", vbExclamation + vbOKOnly
        Exit Sub
    End If
    
    If vbYes <> MsgBox("Müşteri ismi: " & Me.ListBox1.Text & vbCr & _
                        "Satılan ürün: " & Me.ListBox2.Text & vbCr & _
                        "Miktar: " & Trim(Me.TextBox1.Text) & vbCr & vbCr & _
                        "Satış işlemini onaylıyor musunuz?", vbQuestion + vbYesNo) Then Exit Sub

Dim QuantityInStocks As Long

    If CheckAvailableQuantity(Me.ListBox2.Text, CLng(Trim(Me.TextBox1.Text)), QuantityInStocks) Then
        With ThisWorkbook.Sheets(Str_SheetName_SalesData)
            .Activate
            i = 0
            While .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Customers) <> ""
                i = i + 1
            Wend
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Customers) = Me.ListBox1.Text
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Products) = Me.ListBox2.Text
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_Quantity) = Me.TextBox1.Text
            .Cells(Lng_RowStartID_OutputData + i, Lng_ColID_OutputData_SalesDate) = Format(Now, "dd.mmmm.yyyy hh:mm:ss")
        End With
        MsgBox "Stoklarda " & QuantityInStocks & " adet ürün kalmıştır.", vbInformation + vbOKOnly
        Me.TextBox1.Text = ""
    Else
        MsgBox "Stoklarda " & QuantityInStocks & " adet ürün kalmıştır." & vbCr & "Satış miktarı olan " & _
            CLng(Trim(Me.TextBox1.Text)) & " adet ürün temin edilememektedir.", vbExclamation + vbOKOnly
    End If
    
End Sub

Private Sub UserForm_Initialize()
    FillCustomersList
    FillProductsList
End Sub

Sub FillCustomersList()
Static i As Long
    With ThisWorkbook.Sheets(Str_SheetName_MainPage)
        i = 0
        While .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Customers) <> ""
            Me.ListBox1.AddItem .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Customers)
            i = i + 1
        Wend
    End With
    Me.ListBox1.ListIndex = 0
End Sub

Sub FillProductsList()
Dim ProductQuantity As Integer
Static i As Long
    With ThisWorkbook.Sheets(Str_SheetName_MainPage)
        i = 0
        While .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products) <> ""
            ProductQuantity = CInt(.Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Stocks))
            If ProductQuantity > 0 Then Me.ListBox2.AddItem .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products)
            i = i + 1
        Wend
    End With
    Me.ListBox2.ListIndex = 0
End Sub

Function CheckAvailableQuantity(ByVal SoldProductName As String, ByVal SoldQuantity As Long, FinalQuantityOfProduct As Long) As Boolean
Dim ProductName         As String
Dim ProductQuantity     As Integer
Static i As Long
    With ThisWorkbook.Sheets(Str_SheetName_MainPage)
        i = 0
        While .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products) <> ""
            ProductName = .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Products)
            If ProductName = SoldProductName Then
                ProductQuantity = CInt(.Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Stocks))
                If ProductQuantity >= SoldQuantity Then
                    FinalQuantityOfProduct = ProductQuantity - SoldQuantity
                    .Activate
                    .Cells(Lng_RowStartID_InputData + i, Lng_ColID_InputData_Stocks) = FinalQuantityOfProduct
                    CheckAvailableQuantity = True
                Else
                    FinalQuantityOfProduct = ProductQuantity
                End If
                Exit Function
            End If
            i = i + 1
        Wend
    End With
End Function

Bu kodları UserForm1 Code penceresi içerisine yazmalısınız..

Konu: Excel Hakkında Herşey

Seçenekler

Görünüm

NxN Kare Matris Determinant Hesabı

Bezier Eğrileri (Hesaplama ve Çizdirme Yöntemi)

Excel VBA Başlangıç Bilgileri #1

Excel VBA Başlangıç Bilgileri #2

Gönderi Kuralları