-
Notifications
You must be signed in to change notification settings - Fork 0
/
TKonto.bas
182 lines (146 loc) · 6.01 KB
/
TKonto.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
Attribute VB_Name = "TKonto"
'Protected under "MIT License"
'Copyright (c) 2019 Rafael Orman
'
'You will find the full license on the github repo. "https://raw.githubusercontent.com/Kronos9247/BWM-Makros/master/LICENSE"
'
'Const ErfolgL As Boolean = True 'Wenn Erfolg nicht benötigt dann True zu False
Const SumL As Boolean = False 'Wenn die Summen-Zeile nicht benötigt wird das True zu einem False ändern!
'Undo Code
Type SaveRange
Val As Variant
Addr As String
Format As String
Borders As Borders
End Type
Option Explicit
Public OldWorkbook As Workbook
Public OldSheet As Worksheet
Public OldSelection() As SaveRange
Sub TKontoErstellen()
Attribute TKontoErstellen.VB_ProcData.VB_Invoke_Func = "T\n14"
'
' TKontoErstellen Makro
'
' Tastenkombination: Strg+Umschalt+T
'
Dim SumLine As Boolean
SumLine = SumL
If TypeName(Selection) = "Range" Then
If Selection.Areas.Count = 1 Then
Dim height As Integer, restHeight As Integer
Dim startX As Integer, startY As Integer
Dim endX As Integer, endY As Integer
height = Selection.Rows.Count
startX = Selection.Column
startY = Selection.Row
endX = startX + 1
endY = startY + height - 1
If (SumLine And height >= 2) Or (Not SumLine And height >= 1) Then
SelectRange startX, startY, endX, endY
AddUndo
'Select header soll
SelectRange startX, startY, startX, startY
ActiveCell.Value = "Soll"
'Select header haben
SelectRange endX, startY, endX, startY
ActiveCell.Value = "Haben"
'Select header
SelectRange startX, startY, endX, startY
Selection.HorizontalAlignment = xlCenter
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
'Select body
SelectRange startX, startY + 1, endX, endY
Selection.NumberFormat = "#,##0.00 $"
Dim i As Integer
If SumLine Then
For i = 0 To 1
ActiveSheet.Cells(endY, startX + i).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-" & (height - 2) & "]C:R[-1]C)"
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDouble
.Weight = xlThick
End With
Next
End If
'Select everything
SelectRange startX, startY, endX, endY
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Application.OnUndo "Undo Macro - TKonto", "TKontoEntfernen"
Else
If SumLine Then
MsgBox "[BWM-Macro] Min height is 2!"
Else
MsgBox "[BWM-Macro] Min height is 1!"
End If
End If
End If
Else
MsgBox "[BWM-Macro] Nothing selected!"
End If
End Sub
Public Function SelectRange(startX As Integer, startY As Integer, endX As Integer, endY As Integer)
With ActiveSheet
.Range(.Cells(startY, startX), _
.Cells(endY, endX)).Select
End With
End Function
Private Function AddUndo()
ReDim OldSelection(Selection.Count)
Set OldWorkbook = ActiveWorkbook
Set OldSheet = ActiveSheet
Dim i As Integer, Cell As Range, Edge As Variant
i = 0
For Each Cell In Selection
i = i + 1
OldSelection(i).Addr = Cell.Address
OldSelection(i).Val = Cell.Formula
OldSelection(i).Format = Cell.NumberFormat
Set OldSelection(i).Borders = Cell.Borders
Next Cell
End Function
Private Sub TKontoEntfernen()
OldWorkbook.Activate
OldSheet.Activate
Dim i As Integer, Cell As Range
For i = 1 To UBound(OldSelection)
Set Cell = Range(OldSelection(i).Addr)
Cell.Formula = OldSelection(i).Val
Cell.NumberFormat = OldSelection(i).Format
Dim Edge As Integer, OldBorder As Borders
If Not OldSelection(i).Borders Is Nothing Then
Set OldBorder = OldSelection(i).Borders
For Edge = XlBordersIndex.xlDiagonalDown To XlBordersIndex.xlInsideHorizontal
If Not OldBorder(Edge) Is Nothing Then
If Not OldBorder(Edge).LineStyle = 1 Then
If OldBorder(Edge).LineStyle = xlNone Then
Cell.Borders(Edge).LineStyle = OldBorder(Edge).LineStyle
Else
With Cell.Borders(Edge)
.LineStyle = OldBorder(Edge).LineStyle
.ColorIndex = OldBorder(Edge).ColorIndex
.TintAndShade = OldBorder(Edge).TintAndShade
.Weight = OldBorder(Edge).Weight
End With
End If
Else
With Cell.Borders(Edge)
.LineStyle = xlNone
End With
End If
Else
With Cell.Borders(Edge)
.LineStyle = xlNone
End With
End If
Next Edge
End If
Next i
Exit Sub
End Sub