Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Bitte um Hilfe bei Code Optimierung

Betrifft: Bitte um Hilfe bei Code Optimierung von: Olaf
Geschrieben am: 31.07.2014 11:45:18

Hallo
Als VBA-Anfänger brauche ich Eure Hilfe.Beiliegendes Macro kopiert Inhalte aus einer Mastertabelle auf ein neues Sheet, wo dann die Mehrheit der Zeilen wieder versteckt wird. Es funktioniert, aber leider ziemlich langsam :-/, da ca. 2000 Zeilen durchforstet werden müssen. Bin für jede Hilfe dankbar, die zur Beschleunigung beitragen. (insbesondere eine bessere Variante für die For-Schleife)Danke im Voraus!
Fred

Sub Staffing()
Dim wks As Worksheet
Dim WSheetC As String
Dim WSheetP As String
Application.DisplayAlerts = False
WSheetP = "Staffing"
WSheetC = "Vorhaben"
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = WSheetP Then
Sheets(WSheetP).Delete
End If
Next
ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = WSheetP
Application.DisplayAlerts = True

Sheets(WSheetC).SelectLastRow = Range("E65536").End(xlUp).Row
'MsgBox "Letzte Zeile ist Nr. " & LastRow
Sheets(WSheetC).Range("A1:K" & LastRow).Select
Sheets(WSheetC).Range("A1:K" & LastRow).Copy
Sheets(WSheetP).Cells(1, 1).PasteSpecial xlPasteAll

Sheets(WSheetC).Range("AB1:AB" & LastRow).Copy
Sheets(WSheetP).Range("L1:L" & LastRow).Insert
Application.ScreenUpdating = False

For i = 17 To LastRow    
   If Sheets(WSheetP).Range("E" & i) = "Status Staffing" Or Sheets(WSheetP).Range("E" & i) = " _
Mitarbeiter Feasibility" Then
Sheets(WSheetP).Rows(i).Hidden = False
    Else    
Sheets(WSheetP).Rows(i).Hidden = True
End If    
Next
Sheets(WSheetP).Rows("1:15").Hidden = True
Sheets(WSheetP).Rows("16").Hidden = False
Columns("D:D").EntireColumn.Hidden = True
Columns("E:E").EntireColumn.Hidden = True
Sheets(WSheetP).Range("A:A").ColumnWidth = "50"
Sheets(WSheetP).Range("F:K").ColumnWidth = "15"
Application.ScreenUpdating = True
End Sub

  

Betrifft: AW: Bitte um Hilfe bei Code Optimierung von: Daniel
Geschrieben am: 31.07.2014 12:41:12

Hi

spricht was dagegen, statt der Schleife ab Zeile 17 einfach den Autofilter zu setzen?
das ist viel schneller als jede Zeile einzeln auszublenden.
der Recorder ist dein Freund.

Gruß Daniel


  

Betrifft: AW: Bitte um Hilfe bei Code Optimierung von: Olaf
Geschrieben am: 31.07.2014 13:30:07

Ciao Daniel
Danke für den Hinweis! Bin gerade am Pröbeln :-)
Gruss Olaf


  

Betrifft: AW: Bitte um Hilfe bei Code Optimierung von: Rudi Maintaire
Geschrieben am: 31.07.2014 13:54:06

Hallo,
erst sammeln dann ausblenden.
Teste mal:

Sub Staffing()
  Dim wks As Worksheet
  Dim WSheetC As String
  Dim WSheetP As String
  Dim rngHide As Range
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  WSheetP = "Staffing"
  WSheetC = "Vorhaben"
  For Each wks In ActiveWorkbook.Worksheets
    If wks.Name = WSheetP Then
      wks.Delete
    End If
  Next wks
  Application.DisplayAlerts = True
  ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)
  ActiveSheet.Name = WSheetP
  With Sheets(WSheetC)
    LastRow = .Range("E65536").End(xlUp).Row
    'MsgBox "Letzte Zeile ist Nr. " & LastRow
    .Range("A1:K" & LastRow).Copy
    Sheets(WSheetP).Cells(1, 1).PasteSpecial xlPasteAll
    .Range("AB1:AB" & LastRow).Copy
    Sheets(WSheetP).Range("L1:L" & LastRow).Insert
  End With
  
  With Sheets(WSheetP)
    For i = 17 To LastRow
      Select Case .Range("E" & i)
        Case "Status Staffing", "Mitarbeiter Feasibility"
          If rngHide Is Nothing Then
            Set rngHide = .Rows(i)
          Else
            Set rngHide = Union(rngHide, .Rows(i))
          End If
      End Select
    Next
    If Not rngHide Is Nothing Then rngHide.Hidden = True
    .Rows("1:15").Hidden = True
    .Range("A:A").ColumnWidth = "50"
    .Range("F:K").ColumnWidth = "15"
  End With
  With Sheets(WSheetC)
    .Columns("D:D").EntireColumn.Hidden = True
    .Columns("E:E").EntireColumn.Hidden = True
  End With
  Application.ScreenUpdating = True
End Sub

Gruß
Rudi