Thema Datum  Von Nutzer Rating
Antwort
Rot Flimmern bei ausführen von Makro trotz Application.ScreenUpdating = False
20.07.2021 07:00:17 Matthias
NotSolved
20.07.2021 09:53:25 Gast32022
NotSolved

Ansicht des Beitrags:
Von:
Matthias
Datum:
20.07.2021 07:00:17
Views:
41
Rating: Antwort:
  Ja
Thema:
Flimmern bei ausführen von Makro trotz Application.ScreenUpdating = False

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


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Flimmern bei ausführen von Makro trotz Application.ScreenUpdating = False
20.07.2021 07:00:17 Matthias
NotSolved
20.07.2021 09:53:25 Gast32022
NotSolved