sorry to post the entire code here. I'm in deep trouble
I want "adding a
row" passes the below test.
'Blocks changes with multiple cells except a deletion of a whole
record ------the test is at the very beginning of the entire code---
If Not undoing And (Target.Columns.Count > 1 Or Target.Rows.Count > 1 Or
(Target.Column = CRECNO And Target.Row > HEADERH) Or (Target.Column =
Range(RTOTALCELL).Column And Target.Row = Range(RTOTALCELL).Row)) Then
'---------------some error message appears here and exits sub---------
thanks.
'-----------------------entire code start-----------------
Public undoing As Boolean
Public selectedCode As String
Public selectedRow As String
Const RTOTALCELL = "L2" 'Toplam kayýt hücresi
Const COLTOTAL = 9 'Toplam sütun sayýsý
Const HEADERH = 2 'Baþlýk satýrlarý sayýsý
Const CRECNO = 1 'Ýþlem no sütunu
Const CREMAINDER = 9 'Bakiye sütunu
Const CCODE = 2 'Kod sütunu
Const COLDATE = 3 'Tarih Sütunu
Const CDEBT = 7 'Borç sütunu
Const CCREDIT = 8 'Alacak sütunu
Const CAUTOMATIC = 2
Private Sub Worksheet_Activate()
undoing = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim m As Long
If undoing Then Exit Sub
'Blocks changes with multiple cells except a deletion of a whole record
If Not undoing And (Target.Columns.Count > 1 Or Target.Rows.Count > 1 Or
(Target.Column = CRECNO And Target.Row > HEADERH) Or (Target.Column =
Range(RTOTALCELL).Column And Target.Row = Range(RTOTALCELL).Row)) Then
If Target.Columns.Count = COLTOTAL - 1 And Target.Rows.Count = 1 And
Application.CountA(Target.Range(Cells(1, 2), Cells(1, COLTOTAL))) = 0 Then
If Range(RTOTALCELL).Value < 1 Then _
Exit Sub
undoing = 1
Call DeleteRecord(Target, selectedCode,
findRecord(selectedCode, Cells(Target.Row, CRECNO)))
If Range(RTOTALCELL).Value < 1 Then _
Exit Sub
If selectedRow = HEADERH + 1 Then
Cells(selectedRow, CREMAINDER) = "=" &
Cells(selectedRow, CDEBT).Address(0, 0) & "-" & Cells(selectedRow,
CCREDIT).Address(0, 0)
Else
If Not selectedRow = Range(RTOTALCELL).Value + HEADERH +
1 Then _
Cells(selectedRow, CREMAINDER) = "=" &
Cells(selectedRow - 1, CREMAINDER).Address(0, 0) & "+" & Cells(selectedRow,
CDEBT).Address(0, 0) & "-" & Cells(selectedRow, CCREDIT).Address(0, 0)
End If
undoing = 0
Exit Sub
End If
MsgBox "Hatalý iþlem."
undoing = 1
Application.Undo
undoing = 0
Exit Sub
End If
If Target.Column = CCODE Then
'Checks if the worksheet exists
If Not sheetExists(Target) Then
MsgBox "Hatalý kod."
undoing = 1
Application.Undo
undoing = 0
Exit Sub
End If
End If
m = Range(RTOTALCELL).Value + HEADERH + 1
If Target.Column < COLTOTAL And Target.Row < m And Target.Row > HEADERH
Then
If Cells(Target.Row, CRECNO) < 1 Then
If Application.CountA(Range(Cells(Target.Row, 1),
Cells(Target.Row, COLTOTAL))) = COLTOTAL - CAUTOMATIC - 1 Then
undoing = 1
Call AddNewRecord(Cells(Target.Row, CCODE).Value,
Worksheets(Cells(Target.Row, CCODE).Value).Range(RTOTALCELL).Value + HEADERH
+ 1, Target.Row, False)
Cells(Target.Row - 1, CREMAINDER).AutoFill
Range(Cells(Target.Row - 1, CREMAINDER), Cells(m - 1, CREMAINDER)),
xlFillDefault
undoing = 0
End If
Exit Sub
End If
If Target.Column = CCODE Then
undoing = 1
Call MoveRecord(Target)
undoing = 0
Exit Sub
End If
'Updates the existing record on the matching worksheet as well
undoing = 1
Call UpdateRecord(Target, Cells(Target.Row, CCODE).Value)
undoing = 0
End If
If Len(Cells(m, COLDATE)) = 0 Then _
Exit Sub
'Adds a new record
If Application.CountA(Range(Cells(m, 1), Cells(m, COLTOTAL))) =
COLTOTAL - CAUTOMATIC - 1 Then
undoing = 1
Call AddNewRecord(Cells(m, CCODE).Value, Worksheets(Cells(m,
CCODE).Value).Range(RTOTALCELL).Value + HEADERH + 1, m, False)
Range(Cells(Target.Row, 1), Cells(Target.Row, COLTOTAL)).Style =
"myDefault"
If Range(RTOTALCELL).Value = 1 Then
Cells(Target.Row, CREMAINDER) = "=" & Cells(Target.Row,
CDEBT).Address(0, 0) & "-" & Cells(Target.Row, CCREDIT).Address(0, 0)
Else
Cells(Target.Row, CREMAINDER) = "=" & Cells(Target.Row - 1,
CREMAINDER).Address(0, 0) & "+" & Cells(Target.Row, CDEBT).Address(0, 0) &
"-" & Cells(Target.Row, CCREDIT).Address(0, 0)
End If
undoing = 0
End If
End Sub
Public Sub AddNewRecord(ByVal b As String, ByVal t As Long, ByVal m As Long,
ByVal auto As Boolean)
Dim x, newrecordno As Long
Dim myRange As Range
Worksheets(b).Range(Worksheets(b).Cells(t, 1), Worksheets(b).Cells(t,
COLTOTAL - 1)).Insert Shift:=xlDown
Worksheets(b).Range(Worksheets(b).Cells(t, 1), Worksheets(b).Cells(t,
COLTOTAL - 1)).Font.FontStyle = "Normal"
Range(Cells(m, 1), Cells(m, COLTOTAL - 1)).Copy
Destination:=Worksheets(b).Range(Worksheets(b).Cells(t, 1),
Worksheets(b).Cells(t, COLTOTAL - 1))
If Len(Cells(m, CDEBT)) > 0 Then
Worksheets(b).Cells(t, CDEBT).Cut
Destination:=Worksheets(b).Cells(t, CCREDIT)
Else
Worksheets(b).Cells(t, CCREDIT).Cut
Destination:=Worksheets(b).Cells(t, CDEBT)
End If
Range(RTOTALCELL).Value = Range(RTOTALCELL).Value + 1
Worksheets(b).Range(RTOTALCELL).Value =
Worksheets(b).Range(RTOTALCELL).Value + 1
Worksheets(b).Range(Worksheets(b).Cells(t, 1), Worksheets(b).Cells(t,
COLTOTAL)).Style = "myDefault"
If Not auto Then
'Finds the smallest possible record number for the new record
For x = 1 To Range(RTOTALCELL).Value + HEADERH + 1
Set myRange = Range(Cells(HEADERH + 1, CRECNO),
Cells(Range(RTOTALCELL).Value + 13, CRECNO)).Find(x, LookIn:=xlValues)
If myRange Is Nothing Then
newrecordno = x
Exit For
End If
Next x
Else
'************
newrecordno = Range(RTOTALCELL).Value
'************
End If
Cells(m, CRECNO) = newrecordno
Worksheets(b).Cells(t, CRECNO) = newrecordno
End Sub
Public Sub MoveRecord(ByVal Target As Range)
Dim k, sheetindex, rowindex As Long
Dim found As Boolean
Dim mySheet As Worksheet
'Finds the matching record
For Each mySheet In Worksheets
For k = 1 To mySheet.Range(RTOTALCELL)
If (Not mySheet.Name = "MAHSUP" And Not mySheet.Name =
"Ayarlar" And Not mySheet.Name = "BOÞ") And mySheet.Cells(k + 2, 1) =
Cells(Target.Row, 1) Then
found = 1
sheetindex = mySheet.Name
rowindex = k + 2
Exit For
End If
Next k
If found = 1 Then
found = 0
Exit For
End If
Next mySheet
'Moves the record to the matching worksheet and deletes it from the
existing one
If Not Worksheets(sheetindex).Name = Target.Value Then
Worksheets(sheetindex).Range(Worksheets(sheetindex).Cells(rowindex,
1), Worksheets(sheetindex).Cells(rowindex, COLTOTAL - 1)).Copy
Destination:=Worksheets(Target.Value).Range(Worksheets(Target.Value).Cells(Worksheets(Target.Value).Range(RTOTALCELL)
+ HEADERH + 1, 1),
Worksheets(Target.Value).Cells(Worksheets(Target.Value).Range(RTOTALCELL) +
HEADERH + 1, COLTOTAL - 1))
Worksheets(Target.Value).Cells(Worksheets(Target.Value).Range(RTOTALCELL)
+ HEADERH + 1, CCODE) = Target.Value
Worksheets(Target.Value).Range(RTOTALCELL) =
Worksheets(Target.Value).Range(RTOTALCELL) + 1
Worksheets(sheetindex).Range(Worksheets(sheetindex).Cells(rowindex,
1), Worksheets(sheetindex).Cells(rowindex, COLTOTAL - 1)).Delete Shift:=xlUp
Worksheets(sheetindex).Range(RTOTALCELL) =
Worksheets(sheetindex).Range(RTOTALCELL) - 1
End If
End Sub
Public Sub UpdateRecord(ByVal Target As Range, ByVal b As String)
Dim x As Long
x = findRecord(b, Cells(Target.Row, CRECNO).Value)
If Application.CountA(Range(Cells(Target.Row, 1), Cells(Target.Row,
COLTOTAL))) = CAUTOMATIC Then
Call DeleteRecord(Target, b, x)
Exit Sub
End If
Select Case Target.Column
Case Is = CDEBT
Worksheets(b).Cells(x, CCREDIT) = Target
Case Is = CCREDIT
Worksheets(b).Cells(x, CDEBT) = Target
Case Else
Worksheets(b).Cells(x, Target.Column) = Target
End Select
End Sub
Public Sub DeleteRecord(ByVal Target As Range, ByVal b As String, myRow As
Long)
Worksheets(b).Range(Worksheets(b).Cells(myRow, 1),
Worksheets(b).Cells(myRow, COLTOTAL)).Delete Shift:=xlUp
Range(Cells(Target.Row, 1), Cells(Target.Row, COLTOTAL)).Delete
Shift:=xlUp
Worksheets(b).Range(RTOTALCELL) = Worksheets(b).Range(RTOTALCELL) - 1
Range(RTOTALCELL).Value = Range(RTOTALCELL).Value - 1
MsgBox "Kayýt silindi."
End Sub
Public Function sheetExists(ByVal n As String)
Dim mySheet As Worksheet
For Each mySheet In Worksheets
If mySheet.Name = n Then
sheetExists = True
Exit Function
End If
Next mySheet
sheetExists = False
End Function
Public Function findRecord(b As String, recordindex As Long)
Dim c, x As Long
c = 1
x = HEADERH + 1
Do While c > 0
If Worksheets(b).Cells(x, CRECNO) = "" Then _
c = 0
If Worksheets(b).Cells(x, CRECNO) = recordindex Then
findRecord = x
Exit Function
End If
x = x + 1
Loop
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Columns.Count = COLTOTAL - 1 And Target.Rows.Count = 1 Then
selectedCode = Cells(Target.Row, CCODE)
selectedRow = Target.Row
End If
End Sub
Public Sub AutomaticEntry()
Dim m, currentrow As Long
Dim myStart, myEnd As Long
myStart = Worksheets("Ayarlar").Range("e10") + HEADERH
myEnd = Worksheets("Ayarlar").Range("e11") + HEADERH
If myStart < 1 + HEADERH Then
MsgBox "Hatalý baþlangýç noktasý."
Exit Sub
End If
If myEnd < 1 + HEADERH Then
MsgBox "Hatalý bitiþ noktasý."
Exit Sub
End If
If myStart > myEnd Then
MsgBox "Baþlangýç bitiþten büyük olamaz."
Exit Sub
End If
If myStart <= Range(RTOTALCELL).Value Then
MsgBox "Hatalý baþlangýç noktasý."
Exit Sub
End If
Sheets("MAHSUP").Select
For currentrow = myStart To myEnd
m = Range(RTOTALCELL).Value + HEADERH + 1
If Not sheetExists(Cells(currentrow, CCODE).Value) Then
MsgBox "Hatalý kod."
Exit Sub
End If
undoing = 1
Call AddNewRecord(Cells(currentrow, CCODE).Value,
Worksheets(Cells(currentrow, CCODE).Value).Range(RTOTALCELL).Value + HEADERH
+ 1, currentrow, True)
'Cells(currentrow - 1, CREMAINDER).AutoFill Range(Cells(currentrow -
1, CREMAINDER), Cells(m - 1, CREMAINDER)), xlFillDefault
undoing = 0
Next currentrow
Sheets("MAHSUP").Cells(currentrow, 1).Select
End Sub
'-----------------------end-----------------
