Exceloberfläche nach Makro eingefroren
30.10.2023 15:01:40
Jakob
Der Code scheint beendet, auch wenn ich am Ende eine Messagebox ausgebe funktioniert das und kommt auch so weit, aber dann kann ich keine Zellen mehr selektieren bis ich eine andere Excel Arbeitsmappe auswähle und wieder zurück in mein Ausgangsfile klicke.
Sub KreditCard()
'Progressbar Variablen
Dim Schritt As Double
Dim Länge As Double
'Prozess Variablen
Dim CCSumBetrag As Currency
Dim CCSumKauf As Currency
Dim CCWb As Workbook
Dim CCDate As Date
Dim wshNet As Object
Dim vRow As Long
Dim vColumn As Long
Dim i As Long
Dim e As Long
Dim Y As Long
Dim vBut As Variant
Dim vWs As Worksheet
Dim vRowCC, vRowVB, vRowAP, vRowHO, vRowDC, vRowDCB As Long 'Zeilencounter
Dim vStart As Long
Dim vWeiter As Long
Dim vEnd As Long
Dim vRefVB As String
Dim vWb As Workbook
Dim shape As shape
Dim hasButtons As Boolean
5: Set vWb = ActiveWorkbook
6: e = GetLastRow
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7: Balken_SW = e + 3 'Gesamt Schritte festlegen
8: Länge = 0
9: Schritt = PB1.Label1.Width / Balken_SW
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Application.ScreenUpdating = False
'NewSave
10: Set vWs = ActiveSheet
11: For vRow = 1 To e
12: If vWs.Cells(vRow, 1) = "//AT*********************/EUR" And vWs.Cells(vRow, 1).Interior.Pattern = xlNone Then 'Volksbank
13: If vWs.Cells(vRow, 15) Like "DC BANK" & Chr(42) Then '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~DC Bank
14: If WorksheetExists("DC_buchen") = False Then
15: vRowDC = 2
Sheets.Add(After:=ActiveSheet).Name = "DC_buchen"
16: With ActiveWorkbook.Sheets("DC_buchen").Tab
17: .ThemeColor = xlThemeColorAccent6 'sehr dunkles grün
18: .TintAndShade = -0.499984740745262
19: End With
20: End If
21: If vRefVB = "" Then vRefVB = GetSAPKreditReferenz(vWs.Cells(vRow, 3), "*******") 'Wenn das erste mal eine Zeile die VB betrifft wird dessen Referenz ausgelesen.
22: vWs.Rows(vRow).Interior.ThemeColor = xlThemeColorAccent6
23: vWs.Rows(vRow).Interior.TintAndShade = -0.499984740745262
24: Sheets("DC_buchen").Cells.Cells(vRowDC, 1) = vWs.Cells(vRow, 10) '"vBetrag_Kopf"
25: Sheets("DC_buchen").Cells(vRowDC, 2) = Format(vWs.Cells(vRow, 3), "dd.MM.yyyy") '"vBelegdatum_Kopf"
26: Sheets("DC_buchen").Cells(vRowDC, 7) = Month(vWs.Cells(vRow, 3)) '"vPeriode_Kopf"
27: Sheets("DC_buchen").Cells(vRowDC, 8) = "**********" 'Hauptgeldverrechnungskonto
28: Sheets("DC_buchen").Cells(vRowDC, 9) = vRefVB 'Referenz Text
29: Sheets("DC_buchen").Cells(vRowDC, 5) = "**********" 'Debitor
30: vStart = InStr(vWs.Cells(vRow, 15), " BR######") + 3
31: vEnd = InStr(vStart + 6, vWs.Cells(vRow, 15), " SG######")
32: Sheets("DC_buchen").Cells(vRowDC, 6) = Trim(Mid(vWs.Cells(vRow, 15), vStart, vEnd)) 'Turnover
' Sheets("DC_buchen").Cells(vRowDC, 4) = "" 'Kostenstelle
' Sheets("DC_buchen").Cells(vRowDC, 3) = "" 'Auftrag
33: vRowDC = vRowDC + 1
34: ElseIf vWs.Cells(vRow, 15) Like "AMERICAN EXPRESS PAYMENTS" & Chr(42) Then '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~American Express Payments
35: If WorksheetExists("AP_buchen") = False Then
36: vRowAP = 2
Sheets.Add(After:=ActiveSheet).Name = "AP_buchen"
37: With ActiveWorkbook.Sheets("AP_buchen").Tab
38: .Color = 15773696 'hellblau
39: .TintAndShade = 0
40: End With
41: End If
42: If vRefVB = "" Then vRefVB = GetSAPKreditReferenz(vWs.Cells(vRow, 3), "*******") 'Wenn das erste mal eine Zeile die VB betrifft wird dessen Referenz ausgelesen.
43: vWs.Rows(vRow).Interior.Color = 15773696
44: Sheets("AP_buchen").Cells.Cells(vRowAP, 1) = vWs.Cells(vRow, 10) '"vBetrag_Kopf"
45: Sheets("AP_buchen").Cells(vRowAP, 2) = Format(vWs.Cells(vRow, 3), "dd.MM.yyyy") '"vBelegdatum_Kopf"
46: Sheets("AP_buchen").Cells(vRowAP, 7) = Month(vWs.Cells(vRow, 3)) '"vPeriode_Kopf"
47: Sheets("AP_buchen").Cells(vRowAP, 8) = "********" 'Hauptgeldverrechnungskonto
48: Sheets("AP_buchen").Cells(vRowAP, 9) = vRefVB 'Referenz Text
49: Sheets("AP_buchen").Cells(vRowAP, 5) = "***********" 'Debitor
50: vStart = InStr(vWs.Cells(vRow, 15), "/BR") + 3
51: vEnd = InStr(vStart + 2, vWs.Cells(vRow, 15), "/DI")
52: Sheets("AP_buchen").Cells(vRowAP, 6) = _
Trim(Mid(vWs.Cells(vRow, 15), vStart, (vEnd - vStart))) 'Turnover
' Sheets("AP_buchen").Cells(vRowAP, 4) = "" 'Kostenstelle
' Sheets("AP_buchen").Cells(vRowAP, 3) = "" 'Auftrag
53: vRowAP = vRowAP + 1
54: ElseIf vWs.Cells(vRow, 15) Like "HOBEX AG" & Chr(42) Then '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~HOBEX
55: If WorksheetExists("HOBEX_buchen") = False Then
56: vRowHO = 2
Sheets.Add(After:=ActiveSheet).Name = "HOBEX_buchen"
57: With ActiveWorkbook.Sheets("HOBEX_buchen").Tab
58: .Color = 5296274 'hellgrün
59: .TintAndShade = 0
60: End With
61: End If
62: If vRefVB = "" Then vRefVB = GetSAPKreditReferenz(vWs.Cells(vRow, 3), "******") 'Wenn das erste mal eine Zeile die VB betrifft wird dessen Referenz ausgelesen.
63: vWs.Rows(vRow).Interior.Color = 5296274
64: Sheets("HOBEX_buchen").Cells(vRowHO, 1) = vWs.Cells(vRow, 10) '"vBetrag_Kopf"
65: Sheets("HOBEX_buchen").Cells(vRowHO, 2) = Format(vWs.Cells(vRow, 3), "dd.MM.yyyy") '"vBelegdatum_Kopf"
66: Sheets("HOBEX_buchen").Cells(vRowHO, 7) = Month(vWs.Cells(vRow, 3)) '"vPeriode_Kopf"
67: Sheets("HOBEX_buchen").Cells(vRowHO, 8) = "********" 'Hauptgeldverrechnungskonto
68: Sheets("HOBEX_buchen").Cells(vRowHO, 9) = vRefVB 'Referenz
69: If InStr(vWs.Cells(vRow, 15), " TURNOVER ") > 0 Then
70: vStart = InStr(vWs.Cells(vRow, 15), "TURNOVER")
71: vEnd = InStr(vStart + 9, vWs.Cells(vRow, 15), "DIS")
72: Sheets("HOBEX_buchen").Cells(vRowHO, 6) = Trim(Mid(vWs.Cells(vRow, 15), vStart + 9, vEnd - (vStart + 9))) '"Turnover"
73: End If
74: If vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]112945 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]112943 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]112944 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]112946 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]112947 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]112948 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]128019 " & Chr(42) Then 'Kostenstelle & Debitor
75: Sheets("HOBEX_buchen").Cells(vRowHO, 4) = "*******"
76: Sheets("HOBEX_buchen").Cells(vRowHO, 5) = "***00008"
77: ElseIf vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]126074 " & Chr(42) Then 'Auftrag & Debitor
78: Sheets("HOBEX_buchen").Cells(vRowHO, 3) = "***94926"
79: Sheets("HOBEX_buchen").Cells(vRowHO, 5) = "***00008"
80: ElseIf vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]112942 " & Chr(42) Then 'Auftrag & Debitor
81: Sheets("HOBEX_buchen").Cells(vRowHO, 3) = "***00608"
82: Sheets("HOBEX_buchen").Cells(vRowHO, 5) = "***00008"
83: ElseIf vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]111601 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]111602 " & Chr(42) Then 'Auftrag & Debitor
84: Sheets("HOBEX_buchen").Cells(vRowHO, 3) = "***00585"
85: Sheets("HOBEX_buchen").Cells(vRowHO, 5) = "***00008"
86: ElseIf vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]111603 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]111604 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]111605 " & Chr(42) Then 'Auftrag & Debitor
87: Sheets("HOBEX_buchen").Cells(vRowHO, 3) = "***00584"
88: Sheets("HOBEX_buchen").Cells(vRowHO, 5) = "***00008"
89: ElseIf vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]126927 " & Chr(42) _
Or vWs.Cells(vRow, 15) Like Chr(42) & "[A-Z]128018 " & Chr(42) Then 'Auftrag & Debitor
90: Sheets("HOBEX_buchen").Cells(vRowHO, 3) = "***00594"
91: Sheets("HOBEX_buchen").Cells(vRowHO, 5) = "***00008"
92: ElseIf vWs.Cells(vRow, 15) Like Chr(42) & "AUFTRAGGEBERREFERENZ: 0035106060" & Chr(42) Then 'Debitor
93: Sheets("HOBEX_buchen").Cells(vRowHO, 5) = "****00014"
94: Sheets("HOBEX_buchen").Cells(vRowHO, 3) = "***00585"
Sheets("HOBEX_buchen").Cells(vRowHO, 3).Interior.Color = 5296274
95: End If
96: vRowHO = vRowHO + 1
97: ElseIf vWs.Cells(vRow, 15) Like "CARD COMPLETE SERVICE BANK AG" & Chr(42) And vWs.Cells(vRow, 15) Like "* DCB *" Then '~~~~~ Diners Club
98: If WorksheetExists("DCB_buchen") = False Then
99: vRowDCB = 2
Sheets.Add(After:=ActiveSheet).Name = "DCB_buchen"
100: With ActiveWorkbook.Sheets("DCB_buchen").Tab
101: .ThemeColor = xlThemeColorAccent4
102: .TintAndShade = 0.599993896298105 'hellgelb
103: End With
104: End If
105: If vRefVB = "" Then vRefVB = GetSAPKreditReferenz(vWs.Cells(vRow, 3), "******") 'Wenn das erste mal eine Zeile die VB betrifft wird dessen Referenz ausgelesen.
106: vWs.Rows(vRow).Interior.ThemeColor = xlThemeColorAccent4
107: vWs.Rows(vRow).Interior.TintAndShade = 0.599993896298105
108: ElseIf vWs.Cells(vRow, 15) Like "CARD COMPLETE SERVICE BANK AG" & Chr(42) Then '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~CARD COMPLETE
109: If WorksheetExists("CC_buchen") = False Then
110: vRowCC = 2
Sheets.Add(After:=ActiveSheet).Name = "CC_buchen"
111: With ActiveWorkbook.Sheets("CC_buchen").Tab
112: .Color = 5287936 'dunkelgrün
113: .TintAndShade = 0
114: End With
115: End If
116: If vRefVB = "" Then vRefVB = GetSAPKreditReferenz(vWs.Cells(vRow, 3), "******") 'Wenn das erste mal eine Zeile die VB betrifft wird dessen Referenz ausgelesen.
Sheets("CC_buchen").Cells(vRowCC, 2) = Format(vWs.Cells(vRow, 3), "dd.MM.yyyy") '"vBelegdatum_Kopf"
Sheets("CC_buchen").Cells(vRowCC, 5) = "*********" '"Debitor" statisch
Sheets("CC_buchen").Cells(vRowCC, 3) = "*********" '"Auftrag" statisch
'unfertig
vRowCC = vRowCC + 1
117: vWs.Rows(vRow).Interior.Color = 5287936
118: End If
119: End If
120: Länge = Länge + Schritt
121: PB1.Label2.Width = Länge
122: PB1.Label3.Caption = Format(Länge / PB1.Label1.Width, "0 %")
123: DoEvents
124: If IsLoaded("PB1") = False Then Exit Sub
125: Next
126: For i = 1 To Worksheets.Count
127: If Sheets(i).Name > vWs.Name Then
128: If Sheets(i).Cells(1, 1) = "" Then
129: Sheets(i).Cells(1, 1) = "vBetrag_Kopf"
130: Sheets(i).Cells(1, 2) = "vBelegdatum_Kopf"
132: Sheets(i).Cells(1, 3) = "Auftrag"
133: Sheets(i).Cells(1, 4) = "Kostenstelle"
134: Sheets(i).Cells(1, 5) = "Debitor"
135: Sheets(i).Cells(1, 6) = "Turnover"
136: Sheets(i).Cells(1, 7) = "vPeriode_Kopf"
137: Sheets(i).Cells(1, 8) = "vKonto_Kopf_Bank"
138: Sheets(i).Cells(1, 9) = "vReferenz_Kopf"
139: End If
140: End If
141: Next i
142: Länge = Länge + Schritt
143: PB1.Label2.Width = Länge
144: PB1.Label3.Caption = Format(Länge / PB1.Label1.Width, "0 %")
145: DoEvents
146: If IsLoaded("PB1") = False Then Exit Sub
147: For Y = 1 To Worksheets.Count
148: Set vWs = Nothing
149: On Error Resume Next
150: Set vWs = vWb.Sheets(Y)
151: On Error GoTo 0
152: If Not vWs Is Nothing And vWs.Cells(1, 1) = "vBetrag_Kopf" Then
153: hasButtons = False
154: For Each shape In vWs.Shapes
155: If shape.Type = xlButtonControl Then
156: hasButtons = True
157: Exit For
158: End If
159: Next shape
160: If hasButtons = False Then
161: i = vWs.UsedRange.Row + vWs.UsedRange.Rows.Count - 1
162: If i = 1 Then
' vWS.Delete
163: Else
' e = vWS.UsedRange.Column + vWS.UsedRange.Columns.Count - 1
' vWS.ListObjects.Add(xlSrcRange, Range(Cells(1, 1), Cells(i, e)), , xlYes).Name = "Tabelle" & y
164: vWs.Columns("A:I").EntireColumn.AutoFit
165: Set vBut = vWs.Buttons.Add(Range("K1").Left, Range("K1").Top, 60, 30)
' Platzierung auf Zellen festlegen (A1 in diesem Beispiel)
166: vBut.Top = vWs.Range("K1").Top
167: vBut.Left = vWs.Range("K1").Left
168: vBut.OnAction = "PERSONAL.XLSB!KreditCardBuchen"
169: vBut.Characters.Text = "buchen"
' vBut.Placement = Excel.XlPlacement.xlFreeFloating
170: vBut.Placement = xlMoveAndSize
With vBut.Characters(Start:=1, Length:=6).Font
171: .Name = "Frutiger LT Std 55 Roman"
172: .FontStyle = "Standard"
173: .Size = 11
174: .Strikethrough = False
175: .Superscript = False
176: .Subscript = False
177: .OutlineFont = False
178: .Shadow = False
179: .Underline = xlUnderlineStyleNone
180: .ColorIndex = 1
181: End With
182: vWs.Sort.SortFields.Clear
vWs.Sort.SortFields.Add2 Key:=Range( _
"A1:A" & i), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
183: With vWs.Sort
184: .SetRange Range(Cells(2, 1), Cells(i, 9))
185: .Header = xlNo
186: .MatchCase = False
187: .Orientation = xlTopToBottom
188: .SortMethod = xlPinYin
189: .Apply
190: End With
191: End If
192: End If
193: End If
194: Next Y
195: Länge = Länge + Schritt + Schritt
196: PB1.Label2.Width = Länge
197: PB1.Label3.Caption = Format(Länge / PB1.Label1.Width, "0 %")
198: DoEvents
199: Application.Wait (Now + TimeValue("0:00:1"))
200: Unload PB1
vWb.Sheets(1).Range("A1").Select --------------------------- schlägt fehl weil die Arbeitsmappe für mehrere Minuten nicht mehr fokussiert werden kann (Workaround zweite Arbeitsmappe öffnen und schließen, dann gehts wieder.)
'Application.ScreenUpdating = True
'SendEmailBuchenRPA
End Sub