|
Hallo Ihr Lieben, habe seit Umstellung auf Office 2016 Propleme mit folgenden Makros.
1. Flimmern bei ausführen des Makros trotz Application.ScreenUpdating = False
2. Pivottabelle Ansicht geht nicht weg trotz ActiveWorkbook.ShowPivotTableFieldList = False
Public Sub Makro_ausführen()
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'ActiveWorkbook.ShowPivotTableFieldList = False
If WorkBookExists("export.MHTML") Then Workbooks("export.MHTML").Close False
Sheets("Auswertung").Select
Range("A1:T441").Select
Selection.Clear
' Application.WindowState = xlMinimized
Application.Run "Importiere_Daten"
Application.Run "Makro6"
Call Test
'AppActivate "Geier Export EBM Leistungen.xls"
'Application.Workbooks("Geier Export EBM Leistungen.xlsm").Windows(1).WindowState = xlMaximized
Application.Run "In_den_Vordergrund"
End Sub
Public Sub Importiere_Daten()
IMPORT_PATH = "\\kliniken-es.de\KE-DFS1\FolderRedirect\geier\My Documents\SAP\SAP GUI\"
Const IMPORT_FILENAME = "export.MHTML"
Const TARGET_SHEET = "Test"
Dim objWorkbook As Workbook
Dim objSheet As Worksheet
Dim blnOpen As Boolean, blnFound As Boolean
Application.ScreenUpdating = False
With ThisWorkbook
For Each objSheet In .Worksheets
If objSheet.Name = TARGET_SHEET Then
objSheet.Cells.ClearContents
blnFound = True
Exit For
End If
Next
If Not blnFound Then
Set objSheet = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
objSheet.Name = TARGET_SHEET
End If
End With
For Each objWorkbook In Workbooks
If objWorkbook.Name = IMPORT_FILENAME Then
blnOpen = True
Exit For
End If
Next
If Not blnOpen Then Set objWorkbook = Workbooks.Open(Filename:= _
IMPORT_PATH & IMPORT_FILENAME, ReadOnly:=True)
objWorkbook.Worksheets(1).Columns("A:P").Copy _
Destination:=objSheet.Cells(1, 1)
objWorkbook.Close SaveChanges:=False
Set objWorkbook = Nothing
Set objSheet = Nothing
Application.Goto Reference:= _
ThisWorkbook.Worksheets("Test").Cells(1, 1), Scroll:=True
' Application.ScreenUpdating = True
'MsgBox "Aktuelle Daten aus export.MHTML Datei importiert"
End Sub
Sub Makro6()
'
' Makro6 Makro
' Makro am 09.12.2011 von IT aufgezeichnet
'
'
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'ActiveWorkbook.ShowPivotTableFieldList = False
Range("A1:E1046").Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"test!R1C1:R1046C5").CreatePivotTable TableDestination:="", TableName:= _
"PivotTable7", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("PivotTable7").PivotFields("Leistung")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable7").PivotFields("Datum von")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable7").AddDataField ActiveSheet.PivotTables( _
"PivotTable7").PivotFields("Leistungsmenge"), "Anzahl von Leistungsmenge", _
xlCount
' With ActiveSheet.PivotTables("PivotTable7").PivotFields("Datum von")
' .PivotItems("(Leer)").Visible = False
' End With
' With ActiveSheet.PivotTables("PivotTable7").PivotFields("Leistung")
' .PivotItems("(Leer)").Visible = True
'End With
ActiveWorkbook.ShowPivotTableFieldList = False
Call Kopieren_inneuesBlatt
End Sub
Sub Kopieren_inneuesBlatt()
'
Application.ScreenUpdating = False
ActiveWorkbook.ShowPivotTableFieldList = False
Range("A3").Select
ActiveSheet.PivotTables("PivotTable7").PivotSelect "", xlDataAndLabel, True
Selection.Copy
Sheets("Auswertung").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Range("F30").Select
' ActiveWorkbook.ShowPivotTableFieldList = False
Call ZeilenEinfügen2
End Sub
Sub ZeilenEinfügen2()
Dim objWS As Worksheet
Dim lastrow As Long
Dim i As Long
Dim objCell As Range
Application.ScreenUpdating = False
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set objWS = Tabelle1
objWS.Activate
With objWS
For i = lastrow To 4 Step -1
If objWS.Range("A" & i).Value > objWS.Range("A3").Value Then
objWS.Rows(i).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For Each objCell In objWS.Range("B" & i + 1, "B" & Cells(Rows.Count, 2).End(xlDown).Row)
If objCell.Value = "" Then Exit For
Next
objCell.Offset(-1, 2).FormulaLocal = "=SUMME(C" & i + 1 & ":C" & objCell.Row - 1 & ")"
i = i - 1
End If
Next
End With
Call x
'Application.ScreenUpdating = True
End Sub
Sub x()
Dim i As Long, lngColorIndex As Long
' Sheets("Tabelle16").Select
For i = 1 To ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
Select Case Cells(i, 2).Text
Case "E40840": lngColorIndex = 44 ' Sachkosten
Case "E40841": lngColorIndex = 44 ' Sachkosten X-Strahl 100
Case "E34360": lngColorIndex = 4 ' CT-Simulation
Case "E25211": lngColorIndex = 19 ' Aufklärung Bösartig
Case "E25210": lngColorIndex = 19 ' Aufklärung Gutartig
Case "E25214": lngColorIndex = 19 ' Nachsorge
Case "E25321": lngColorIndex = 34 ' Bestrahlung mal.
Case "E25343": lngColorIndex = 24 ' 25343 als Zuschlag zur Gebührenposition 25342 für die rechnerunterstützteHochpräzisionsbestrahlungsplanung(IMRT/ Stereotaxie)
Case "E25321": lngColorIndex = 34 ' 25321 ist für die "Bestrahlung mit einem Linearbeschleuniger bei bösartigen Erkrankungen oder bei raumfordernden Prozessen des zentralen Nervensystems"
Case "E25324": lngColorIndex = 34 ' 25324 als Zuschlag für die Bestrahlung von mehr als einem Zielvolumen / 287 Punkte
Case "E25325": lngColorIndex = 34 ' 25325 als Zuschlag für die Bestrahlung in Hochpräzisionstechnik / 278 Punkte
Case "E25326": lngColorIndex = 34 ' 25326 als Zuschlag für die Bestrahlung mit bildgestützter Einstellung (IGRT) / 524 Punkte
Case "E25327": lngColorIndex = 34 ' 25327 als Zuschlag für die Bestrahlung in Hochpräzisionstechnik in Kombination mit IGRT / 746 Punkte
Case "E25328": lngColorIndex = 34 ' 25328 als Zuschlag bei Überschreitung der Einzeldosis = 2,5 Gy / 577 Punkte
Case "E25310": lngColorIndex = 34 ' Bestrahlung X-Strahl 100
Case "E25322": lngColorIndex = 44 ' Zuschlag > 2 Felder
Case "E25317": lngColorIndex = 34 ' 25317 als Zuschlag für die Bestrahlung von mehr als einem Zielvolumen / 230 Punkte sowie
Case "E25318": lngColorIndex = 34 ' 25318 als Zuschlag für die Bestrahlung mit bildgestützter Einstellung (IGRT) / 318 Punkte
Case "E25323": lngColorIndex = 44 ' Zuschlag 3D
Case "E25320": lngColorIndex = 44 ' Reizbestrahlung
Case "E25316": lngColorIndex = 34 ' 25316 "Bestrahlung mit einem Linearbeschleuniger bei gutartigen Erkrankungen"
Case "E25342": lngColorIndex = 24 ' Bestrahlungsplan
Case "E25341": lngColorIndex = 24 ' Bestrahlungsplan einfach
Case "E25340": lngColorIndex = 24 ' Bestrahlungsplan X-Strahl 100
Case "E40120": lngColorIndex = 50 ' Briefe RT Abschluss
Case "E40144": lngColorIndex = 50 ' Porto RT Abschluss
Case "E40110": lngColorIndex = 50 ' Porto RT Abschluss neu
Case "E40111": lngColorIndex = 50 ' Fax-Kostenpauschale
Case "STWEIT": lngColorIndex = 44 ' Konsil zur Weiterbehandlung
Case "STTHER3D": lngColorIndex = 4 ' CT-Simulation stationär
Case "STBR": lngColorIndex = 50 ' Briefe RT Abschluss stationär
Case "STEINFR-3D": lngColorIndex = 34 ' Zuschlag 3D
Case "STEINFRBIL": lngColorIndex = 39 ' Bildgebung Linac stationär
Case "STEINFRBOE": lngColorIndex = 34 ' Bestrahlung mal. stationär
Case "STEINFRREI": lngColorIndex = 34 ' Bestrahlung gut. stationär
Case "STEINFRZ>2": lngColorIndex = 34 ' Zuschlag > 2 Felder stationär
Case "STTHERWSBL": lngColorIndex = 24 ' Bestrahlungsplan
Case "STAUFKLBE": lngColorIndex = 44 ' Konsil Schnellläufer
Case "STAUFKLG": lngColorIndex = 44 ' Konsil Aufklärunggespräch gutartig/ bosartig
Case "STAUFKLU": lngColorIndex = 44 ' Konsil Körperliche Untersuchung
Case "STTUMOR15": lngColorIndex = 44 ' Konsil Tumorkonferenz
Case "STBOELI1F": lngColorIndex = 22 ' Konsil erste Bestrahlung / Neueinstellung / Boost
Case "STKONSIL15": lngColorIndex = 44 ' Konsil einfache Beratung
' Case "B": lngColorIndex = 4
' Case "C": lngColorIndex = 5
' ...
Case Else: lngColorIndex = xlColorIndexNone
End Select
Cells(i, 1).Resize(, 3).Interior.ColorIndex = lngColorIndex
Next
Call Ergebnis_weg
End Sub
Public Sub Ergebnis_weg()
Dim lngZ As Long
For lngZ = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If InStr(Cells(lngZ, 1), "Ergebnis") > 0 Then
Cells(lngZ, 1).EntireRow.Delete
End If
Next
Call GErgebnis_weg
End Sub
Public Sub GErgebnis_weg()
Dim lngZ As Long
For lngZ = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If InStr(Cells(lngZ, 1), "Gesamtergebnis") > 0 Then
Cells(lngZ, 1).EntireRow.Delete
End If
Next
Call FormelKontrolle
End Sub
Sub FormelKontrolle()
'
' Häufigkeit der Summe ermitteln mit Median
' Abgleich ob Median in F1 mit Summe übereinstimmt
' Kontrolle entfernen wenn kein Bestrahlungscode E25310 oder 25321-25323 auftritt
Range("F1").Select
ActiveCell.FormulaR1C1 = "=MEDIAN(RC[-2]:R[199]C[-2])"
Range("E2").Select
ActiveCell.FormulaR1C1 = _
"=IF(OR(R1C6=RC[-1],RC[-1]="""",RC[-1]=0,RC[1]=0),"" "",""Kontrolle"")"
Range("F2").Select
ActiveCell.FormulaR1C1 = _
"=IF(OR(RC[-4]=""E40840"",RC[-4]=""E40841"",RC[-4]=""E40120"",RC[-4]=""E40144"",RC[-4]=""E34360"",RC[-4]=""E25342"",RC[-4]=""E25341"",RC[-4]=""E25340"",RC[-4]=""E25211"",RC[-4]=""E25210""),0,5)"
Range("E2:f2000").Select
Selection.FillDown
Columns("F:F").Select
Selection.Font.ColorIndex = 2
Columns("E:E").Select
Selection.Font.ColorIndex = 3
Selection.Font.Bold = True
Selection.Font.Italic = True
Columns("D:D").ColumnWidth = 5.29
Range("G1").Select
ActiveCell.FormulaR1C1 = "Hinweis: Sie haben noch "
Range("J1").Select
ActiveCell.FormulaR1C1 = "mal E40840 zur Verfügung (nur für ASV Patienten)"
Range("I1").Select
ActiveCell.FormulaR1C1 = "=SUM(15-SUM(R[1]C[10]:R[199]C[10]))"
Range("I2").Select
Range("G2").Select
Columns("I:I").ColumnWidth = 4.29
Range("G1:L1").Select
With Selection.Font
.Name = "Arial"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 0
End With
Range("G1:R1").Select
Selection.Font.ColorIndex = 3
Selection.Font.Bold = True
Selection.Font.Italic = True
Columns("H:H").ColumnWidth = 18.14
Columns("H:H").ColumnWidth = 31.43
Columns("H:H").ColumnWidth = 35.57
Columns("I:I").ColumnWidth = 6.29
With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With
Range("O3").Select
ActiveCell.FormulaR1C1 = _
"=COUNTIF(R[-1]C[-13]:R[197]C[-13],""E25310"")+COUNTIF(R[-1]C[-13]:R[197]C[-13],""E25316"")+COUNTIF(R[-1]C[-13]:R[197]C[-13],""E25321"")"
Range("T3").Select
ActiveCell.FormulaR1C1 = _
"=IF(OR(R[-1]C[-18]=""E25340"",R[-1]C[-18]=""E25341"",R[-1]C[-18]=""E25342""),R[-1]C[-17],"""")"
Range("T4").Select
Range("Q3").Select
ActiveCell.FormulaR1C1 = "=IF(R[-1]C[-15]=""E40144"",R[-1]C[-14],"""")"
Range("Q4").Select
Range("P3").Select
ActiveCell.FormulaR1C1 = "=IF(R[-1]C[-14]=""E34360"",R[-1]C[-13],"""")"
Range("P4").Select
Range("R3").Select
ActiveCell.FormulaR1C1 = "=IF(R[-1]C[-16]=""E40120"",R[-1]C[-15],"""")"
Range("R4").Select
Range("S3").Select
ActiveCell.FormulaR1C1 = "=IF(R[-1]C[-17]=""E40840"",R[-1]C[-16],"""")"
Range("S4").Select
Range("p3:t2000").Select
Selection.FillDown
Range("G3:N18").Select
With Selection.Interior
.ColorIndex = 50
.Pattern = xlSolid
End With
Range("G3").Select
ActiveCell.FormulaR1C1 = "Quartalsabrechnung:"
Range("G3").Select
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("G8").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-3]C[9]:R[195]C[9])"
Range("H8").Select
ActiveCell.FormulaR1C1 = "CT-Simulation(en)"
Range("G9").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-4]C[13]:R[194]C[13])"
Range("H9").Select
ActiveCell.FormulaR1C1 = "Bestrahlungsplan(pläne)"
Range("G10").Select
ActiveCell.FormulaR1C1 = "=R[-7]C[8]"
Range("H10").Select
ActiveCell.FormulaR1C1 = "Bestrahlung(en) (Hyperfraktionierungen werden nicht addiert)"
Range("G10").Select
Selection.NumberFormat = "0"
Range("G11").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-6]C[11]:R[192]C[11])"
Range("H11").Select
ActiveCell.FormulaR1C1 = "Brief(e)"
Range("G12").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-7]C[10]:R[191]C[10])"
Range("H12").Select
ActiveCell.FormulaR1C1 = "Kopie(n)"
Range("G14").Select
ActiveCell.FormulaR1C1 = "Sonstiges:"
Range("H14").Select
ActiveCell.FormulaR1C1 = "Haben Sie ggf. die Maske abgerechnet"
Range("H16").Select
ActiveCell.FormulaR1C1 = "Sind alle Sachkosten aufgebraucht"
Range("G5:H16").Select
Selection.Font.Bold = True
Range("G14").Select
Selection.Font.Italic = True
Selection.Font.Underline = xlUnderlineStyleSingle
Range("F3").Select
Range("O4").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-2]C[-13]:R[196]C[-13],""E25210"")"
Range("O5").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-3]C[-13]:R[195]C[-13],""E25211"")"
Range("O6").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-4]C[-13]:R[194]C[-13],""E25214"")"
Range("O7").Select
Range("G5").Select
ActiveCell.FormulaR1C1 = "=R[-1]C[8]"
Range("H5").Select
ActiveCell.FormulaR1C1 = "Aufklärungsgespräch(e) ""gutartig"""
Range("H6").Select
Range("G6").Select
ActiveCell.FormulaR1C1 = "=R[-1]C[8]"
Range("G7").Select
Range("H6").Select
ActiveCell.FormulaR1C1 = "Aufklärungsgespärch(e) ""bösartig"""
Range("H7").Select
Range("G7").Select
ActiveCell.FormulaR1C1 = "=R[-1]C[8]"
Range("H7").Select
ActiveCell.FormulaR1C1 = "Nachsorge(n)"
Range("H8").Select
Range("G1:N1").Select
Selection.Font.ColorIndex = 1
Range("G5:L12").Select
Selection.Font.ColorIndex = 0
Range("G13").Select
Range("O1:Z957").Select
Selection.Font.ColorIndex = 2
Range("G3").Select
Selection.Font.ColorIndex = 2
Range("G14").Select
Selection.Font.ColorIndex = 2
Call Makro3
End Sub
Sub Makro3()
'
' Entfernt Pivottabelle in Sheet 1
'ActiveWorkbook.ShowPivotTableFieldList = False
'
Sheets(1).Delete
Sheets("Auswertung").Select
Range("A1").Select
' Application.ScreenUpdating = True
'Application.AskToUpdateLinks = True
'Application.DisplayAlerts = True
End Sub
Option Explicit
Private Declare Function GetWindowPlacement Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByRef lpwndpl As WINDOWPLACEMENT) As Long
Private Declare Function SetWindowPlacement Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByRef lpwndpl As WINDOWPLACEMENT) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type WINDOWPLACEMENT
Length As Long
flags As Long
showCmd As Long
ptMinPosition As POINTAPI
ptMaxPosition As POINTAPI
rcNormalPosition As RECT
End Type
Private Const SW_MAXIMIZE = 3
Private ludtRect As RECT
Public Sub In_den_Vordergrund()
Application.ScreenUpdating = False
ActiveWorkbook.ShowPivotTableFieldList = False
Dim udtWindowplacement As WINDOWPLACEMENT
Dim udtPointapi As POINTAPI
udtWindowplacement.Length = Len(udtWindowplacement)
Call GetWindowPlacement(Application.hwnd, udtWindowplacement)
ludtRect = udtWindowplacement.rcNormalPosition
' Application.WindowState = xlMinimized
With udtWindowplacement
.Length = Len(udtWindowplacement)
.showCmd = SW_MAXIMIZE
.ptMinPosition = udtPointapi
.ptMaxPosition = udtPointapi
.rcNormalPosition = ludtRect
End With
Call SetWindowPlacement(Application.hwnd, udtWindowplacement)
Application.Workbooks("Geier Export EBM Leistungen.xlsm").Windows(1).WindowState = xlMaximized
Application.ScreenUpdating = True
End Sub
Vielen Dank für die Durchsicht.
Gruß Matthias
|