Thin Client und VBA
07.03.2017 21:27:19
Lukas
Hallo
Kann mir jemand sagen ob bei einer Umstellung auf ein Thin Client System mit Problemen zu rechnen ist. ich meinen Excel Makros. Ich mein jetzt nicht das wenn in einem Makro ein Pfad auf die Festplatte angegeben ist das man den ändern muss ist mir schon klar. Würde bspw. solche Sub's Laufen:
Option Explicit
Private Type KW_Block
Daten() As Variant
Anzahl As Long
Zaehler As Long
End Type
' String-Liste vohandener SPs
Private Const conSP_Numbers As String = "RH;TT;1;2;2a;2b;3;4;5;6;7;8;9;10" ' ggf. anpassen ( _
Reihenfolge beachten zwecks Sortierung)
Public Sub KW_Tebellen_Aktualisieren()
Dim wksDatum As Worksheet
Dim wksWochen As Worksheet
Dim lngZeile As Long
Dim lngLetzteZeile As Long
Dim lngSpalte As Long
Dim lngLetzteSpalte As Long
Dim avntUPDatum() As Variant
Dim dicKW As Object
Dim strKWJahr As String
Dim audtKW() As KW_Block
Dim iaudtKW As Long
Dim avntKWDaten() As Variant
' Blatt "UP Datum" der Objektvariablen zuweisen
Set wksDatum = ThisWorkbook.Worksheets("UP Datum")
' Bezogen auf das Blatt "UP Datum"
With wksDatum
' Letzte beschriebene Zeile im Bereich [A:L] ermitteln
lngLetzteZeile = LetzteBeschriebeneZeile(.Range("A:L"))
' Prüfen ob letzte beschriebene Zeile kleiner 3
If lngLetzteZeile < 3 Then
' Objektvariablen-Verweis zerstören und Prozedur verlassen
Set wksDatum = Nothing: Exit Sub
End If
' Daten aus dem Bereich [A3:L & letzte beschriebene Zeile] in Array speichern
avntUPDatum() = .Range("A3:L" & lngLetzteZeile).Value
End With
' Dictionary-Objekt erzeugen und der Objektvariablen zuweisen
Set dicKW = CreateObject("scripting.dictionary")
' Prozedur-Aufruf "KW_Daten_Lesen"
' Daten lesen und in KW-Blöcke unterteilen, die in dicKW und audtKW() gespeichert werden
Call KW_Daten_Lesen(avntUPDatum(), dicKW, audtKW())
' Array Leeren
Erase avntUPDatum
' Prüfen ob keine KWs ermittelt wurden
If dicKW.Count = 0 Then
' Objektvariablen-Verweise zerstören und Prozedur verlassen
Set wksDatum = Nothing
Set dicKW = Nothing
Exit Sub
End If
' Blatt "UP Wochen" der Objektvariablen zuweisen
Set wksWochen = ThisWorkbook.Worksheets("UP Wochen")
' Bezogen auf das Blatt "UP Wochen"
With wksWochen
' Letzte benutzte Zeile ermitteln
lngLetzteZeile = .UsedRange.Row + .UsedRange.Rows.Count + 1
' Prüfen ob letzte benutzte Zeile kleiner 4
If lngLetzteZeile < 4 Then
' Objektvariablen-Verweise zerstören und Prozedur verlassen
Set wksDatum = Nothing
Set dicKW = Nothing
Set wksWochen = Nothing
Exit Sub
End If
' Bildschirm-Aktualisierung ausschalten (Performance-Gewinn)
Application.ScreenUpdating = False
' Alle Zeilen ab der 4. Zeile bis zur letzten benutzten Zeile löschen
.Range(.Rows(4), .Rows(lngLetzteZeile)).EntireRow.Delete
' Letzte beschriebene Spalte in Zeile 3 ermitteln
lngLetzteSpalte = LetzteBeschriebeneSpalte(.Rows(3))
' Durchlaufen der Spalten in 12er Schritten (= KW-Block)
For lngSpalte = 1 To lngLetzteSpalte Step 12
' KW und Jahr verketten und einer String-Variablen zuweisen,
' das als ID dem Dictionary-Objekt "dicKW" dient
strKWJahr = CInt(Val(.Cells(2, lngSpalte + 4).Value)) & "_" & _
Year(CDate(.Cells(2, lngSpalte + 5).Value))
' Prüfen ob die ID "strKWJahr" vorhanden ist
If dicKW.Exists(strKWJahr) Then
' KW-Block-Index der ID auslesen
iaudtKW = dicKW(strKWJahr)
' Daten entsprechend der ID (KW_Jahr-KOmbination) in einem Array _
zwischenspeichern
avntKWDaten() = audtKW(iaudtKW).Daten
' Bezogen auf Zell-Bereich, das in Zeile 4 und entsprechender Spalte aufspannt _
_
wird
With .Cells(4, lngSpalte).Resize(UBound(avntKWDaten, 1), UBound(avntKWDaten, 2)) _
_
' Array-Dtaen dem Bereich zuweisen
.Value = avntKWDaten()
' Prozedur-Aufruf "KW_Block_Formatieren"
Call KW_Block_Formatieren(.Cells)
' Prozedur-Aufruf "KW_Block_Sortieren"
Call KW_Block_Sortieren(.Cells)
' Zell-Formatierung & Ermittlung Anzahl "SP Total" durch dir Funktion " _
AnzahlSP"
.Worksheet.Cells(1, lngSpalte + 3).NumberFormat = """SP (Total):"" * 0"
.Worksheet.Cells(1, lngSpalte + 3).Value = AnzahlSP(KW_Block_Bereich:=. _
_Cells, _
ID_Spalten:=Array(1, 4, 6),
SP_Suchwerte:=Array(2, " 2a", "2b", 3, _
4, 5, 6, 7, 8, 9, 10))
' Zell-Formatierung & Ermittlung Anzahl "SP RH" durch dir Funktion " _
AnzahlSP"
.Worksheet.Cells(1, lngSpalte + 4).NumberFormat = """SP (RH):"" * 0"
.Worksheet.Cells(1, lngSpalte + 4).Value = AnzahlSP(KW_Block_Bereich:=. _
Cells, _
ID_Spalten:=Array(1, 4, _
5, 6), _
SP_Suchwerte:=Array("RH" _
))
' Zell-Formatierung & Ermittlung Anzahl "SP TT" durch dir Funktion " _
AnzahlSP"
.Worksheet.Cells(1, lngSpalte + 5).NumberFormat = """SP (TT):"" * 0"
.Worksheet.Cells(1, lngSpalte + 5).Value = AnzahlSP(KW_Block_Bereich:=. _
Cells,
ID_Spalten:=Array(1, 4, _
5, 6), _
SP_Suchwerte:=Array("TT" _
))
' Zell-Formatierung & Ermittlung Anzahl "SP 1" durch dir Funktion "AnzahlSP" _
_
.Worksheet.Cells(1, lngSpalte + 6).NumberFormat = """SP (1):"" * 0"
.Worksheet.Cells(1, lngSpalte + 6).Value = AnzahlSP(KW_Block_Bereich:=. _
Cells, _
ID_Spalten:=Array(1, 4, _
5, 6), _
SP_Suchwerte:=Array(1))
End With
Else
' nix
End If
Next
' Bildschirm-Aktualisierung einschalten
Application.ScreenUpdating = True
' Springe zur 1. Zelle ([A1])
Application.Goto .Cells(1)
' Zur Spalte mit aktueller KW Scrollen, falls vorhanden
For lngSpalte = 1 To LetzteBeschriebeneSpalte(.Rows(2)) Step 12
If .Cells(2, lngSpalte + 4).Value = DIN_KW(Date) Then
If Year(.Cells(2, lngSpalte + 5).Value) = Year(Date) Then
ActiveWindow.ScrollColumn = lngSpalte
Exit For
End If
End If
Next
End With
' Objektvariablen-Verweis zerstören
Set dicKW = Nothing
End Sub
Private Sub KW_Block_Sortieren(ByRef rngBereich As Range)
Dim astrSP_Numbers() As String
Dim iastrSPN As Long
Dim strFormel As String
' conSP_Numbers = "RH;TT;1;2;2a;2b;3;4;5;6;7;8;9;10" ' siehe oben
' SP_Number-String in Array zerlegen und zuweisen
astrSP_Numbers() = Split(conSP_Numbers, ";")
' Array-Matrix-String als Teile des Formlausdrucks erzeugen
For iastrSPN = LBound(astrSP_Numbers) To UBound(astrSP_Numbers)
If IsNumeric(astrSP_Numbers(iastrSPN)) Then
strFormel = strFormel & ";" & (astrSP_Numbers(iastrSPN) * 1) & "," & iastrSPN
Else
strFormel = strFormel & ";""" & astrSP_Numbers(iastrSPN) & """," & iastrSPN
End If
Next
' Formel-String vervollständigen
strFormel = "=VLOOKUP(RC[-12],{" & Mid$(strFormel, 2) & "},2,0)"
' Beziogen auf den übergebenen Zell-Bereich
With rngBereich
' Spalte 6, 5, 4 aufsteigend sortieren
.Sort .Cells(1, 6), xlAscending, Header:=xlNo ' Datum von
.Sort .Cells(1, 5), xlAscending, Header:=xlNo ' Vorname
.Sort .Cells(1, 4), xlAscending, Header:=xlNo ' Name
' SP
' Bezogen auf den Spalten-Bereich am Ende des übergebenen Zellbereicha
With .Columns(.Columns.Count).Offset(, 1)
' Formeln eintragen
.FormulaR1C1 = strFormel
' Bezogen auf den übergebenenzell-Bereich inklusive des Spalten-Bereichs
With Range(.Offset(, -12), .Cells)
' Nach Spalten-Bereich aufsteigend sortieren
.Sort .Cells(1, 13), xlAscending, Header:=xlNo
End With
' Inhalt des Spalten-Bereichs löschen, diente nur der bedingten Sortierung der SP- _
Spalte
.ClearContents
End With
End With
End Sub
Private Sub KW_Block_Formatieren(ByRef rngBereich As Range)
Dim avntSP As Variant
Dim iavntSP As Long
Dim vntSP As Variant
Dim vntIndexA As Variant ' A = Anfang
Dim vntIndexE As Variant ' E = Ende
Dim blnColored As Boolean
' SP_Number-String in Array zerlegen und zuweisen
avntSP = Split(conSP_Numbers, ";")
' Beziogen auf den übergebenen Zell-Bereich
With rngBereich
' Aufsteigend Sortieren nach Spalte1 und Spalte2
.Sort .Cells(1, 1), xlAscending, .Cells(1, 2), , xlAscending, Header:=xlNo
' Alle SP-Bezeichnungen durchlaufen
For iavntSP = LBound(avntSP) To UBound(avntSP)
' prüfen ob SP eine Zahl ist
If IsNumeric(avntSP(iavntSP)) Then
' SP in Zahl umwandeln
vntSP = CDbl(avntSP(iavntSP))
Else
' SP bleibt wie es ist
vntSP = avntSP(iavntSP)
End If
' Index des 1. Auftreten von SP in Spalte 1 ermitteln
vntIndexA = Application.Match(vntSP, .Columns(1), 0)
' Prüfen ob Index eine Zahl und kein Fehlerwert (= SP vorhanden)
If IsNumeric(vntIndexA) Then
' Index des 2. Auftreten von SP in Spalte 1 ermitteln
vntIndexE = Application.Match(vntSP, .Columns(1), 1)
' Bezogen auf den Zell-Bereich zw. den 2 ermittelten Zeilen-Indizes
With Range(.Rows(CLng(vntIndexA)), .Rows(CLng(vntIndexE)))
' Prüfen und Formatieren entsprechend SP
Select Case CStr(vntSP)
Case "1"
' Index des 1. Auftreten von 40 in Spalte 2 ermitteln
vntIndexA = Application.Match(40, .Columns(2), 0)
' Prüfen ob Index eine Zahl und kein Fehlerwert (= 40 vorhanden)
If IsNumeric(vntIndexA) Then
' Index des 2. Auftreten von 40 in Spalte 2 ermitteln
vntIndexE = Application.Match(40, .Columns(2), 1)
' Schriftfarbe im Zell-Bereich zw. den 2 ermittelten Zeilen- _
Indizes setzen
Range(.Rows(vntIndexA), .Rows(vntIndexE)).Font.Color = RGB(255, _
_
0, 0)
End If
Case "2", "2a", "2b"
' Zell-Hintergrund färben
.Interior.Color = RGB(217, 217, 217)
Case "3"
.Interior.Color = RGB(255, 102, 153)
Case "4"
.Interior.Color = RGB(250, 191, 143)
Case "5"
.Interior.Color = RGB(255, 255, 153)
Case "6"
' nix
Case "7"
.Interior.Color = RGB(204, 255, 153)
Case "8"
.Interior.Color = RGB(220, 230, 241)
Case "9"
.Interior.Color = RGB(141, 180, 226)
Case "10"
.Interior.Color = RGB(177, 160, 199)
Case "RH", "TT"
' Zell-Hintergrund färben
.Interior.Color = RGB(255, 255, 0)
' Zell-Schrift färben
.Font.Color = RGB(255, 0, 0)
Case Else
End Select
End With
End If
Next
' Bezogen auf den Schnitt-Zell-Bereich (KW-Block u. Bereich ["B:C"])
With Intersect(.Cells, .Columns(2).Resize(, 2))
' Zell-Hintergrundfarbe zurücksetzen
.Interior.ColorIndex = xlColorIndexNone
' Zell-Schriftfarbe zurücksetzen
.Font.ColorIndex = xlColorIndexAutomatic
End With
' Rahmen setzen
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlHairline
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThick
End With
End Sub
Private Sub KW_Daten_Lesen(ByRef avntUPDatum() As Variant, ByRef dicKW As Object, ByRef audtKW() _
_
As KW_Block)
Dim iavntUPD1 As Long
Dim iavntUPD2 As Long
Dim vntDatumVon As Variant
Dim vntDatumBis As Variant
Dim datKWDatumVon As Date
Dim datKWDatumBis As Date
Dim datKWDatum As Date
Dim vntKW As Variant
Dim strKWJahr As String
Dim iaudtKW As Long
' Daten zeilenweise durchlaufen
For iavntUPD1 = LBound(avntUPDatum, 1) To UBound(avntUPDatum, 1)
vntDatumVon = avntUPDatum(iavntUPD1, 6)
vntDatumBis = avntUPDatum(iavntUPD1, 7)
' Prüfen ob "DatumVon" ein Datum ist
If IsDate(vntDatumVon) Then
' Prüfen ob "DatumBis" kein Datum ist
If Not IsDate(vntDatumBis) Then
' "DatumBis" "DatumVon" zuweisen
vntDatumBis = vntDatumVon
End If
' Prüfen ob "DatumVon" kleiner oder gleich "DatumBis"
If vntDatumVon <= vntDatumBis Then
' Datum des 1. Wochentags (= Montag) ermitteln und zuweisen
datKWDatumVon = CDate(vntDatumVon) - Weekday(CDate(vntDatumVon), 2) + 1
' Datum des 1. Wochentags (= Montag) ermitteln und zuweisen
datKWDatumBis = CDate(vntDatumBis) - Weekday(CDate(vntDatumBis), 2) + 1
' Daten KW-weise (Schritteweite = 7) durchlaufen
For datKWDatum = datKWDatumVon To datKWDatumBis Step 7
' ID "strKWJahr" ermitteln durch Verkettung von KW und Jahr
strKWJahr = DIN_KW(datKWDatum) & "_" & Year(datKWDatum)
' ID in Dictionary-Objekt speichern und hochzählen
dicKW(strKWJahr) = dicKW(strKWJahr) + 1
Next
End If
End If
Next
' Prüfen on mind. 1 ID in Dict.-Objekt vorhanden
If dicKW.Count > 0 Then
' Benutzerdef. Array-Type dimensionieren
ReDim audtKW(1 To dicKW.Count)
' Alle Element (ID) des Dict.-Objektes durchlaufen
For Each vntKW In dicKW.Keys
' Benutzerdef. Array-Type-Zähler inkrementieren
iaudtKW = iaudtKW + 1
' Bezogen auf Type-Array-Element
With audtKW(iaudtKW)
' Anzahl der IDs (KW_Jahr) zuweisen
.Anzahl = dicKW(vntKW)
' Daten-Array dimensionieren (aufspannen)
ReDim .Daten(1 To .Anzahl, LBound(avntUPDatum, 2) To UBound(avntUPDatum, 2))
End With
' Array-Type-Zähler zuweisen
dicKW(vntKW) = iaudtKW
Next
' Daten zeilenweise durchlaufen
For iavntUPD1 = LBound(avntUPDatum, 1) To UBound(avntUPDatum, 1)
vntDatumVon = avntUPDatum(iavntUPD1, 6)
vntDatumBis = avntUPDatum(iavntUPD1, 7)
' Prüfen ob "DatumVon" ein Datum ist
If IsDate(vntDatumVon) Then
' Prüfen ob "DatumBis" kein Datum ist
If Not IsDate(vntDatumBis) Then
' "DatumBis" "DatumVon" zuweisen
vntDatumBis = vntDatumVon
End If
' Prüfen ob "DatumVon" kleiner oder gleich "DatumBis"
If vntDatumVon <= vntDatumBis Then
' Datum des 1. Wochentags (= Montag) ermitteln und zuweisen
datKWDatumVon = CDate(vntDatumVon) - Weekday(CDate(vntDatumVon), 2) + 1
' Datum des 1. Wochentags (= Montag) ermitteln und zuweisen
datKWDatumBis = CDate(vntDatumBis) - Weekday(CDate(vntDatumBis), 2) + 1
' Daten KW-weise (Schritteweite = 7) durchlaufen
For datKWDatum = datKWDatumVon To datKWDatumBis Step 7
' ID "strKWJahr" ermitteln durch Verkettung von KW und Jahr
strKWJahr = DIN_KW(datKWDatum) & "_" & Year(datKWDatum)
' Array-Type-Zähler zuweisen
iaudtKW = dicKW(strKWJahr)
' Bezogen auf Type-Array-Element
With audtKW(iaudtKW)
' Daten-Array-Zähler inkrementieren
.Zaehler = .Zaehler + 1
' Daten-Array spaltenweise füllen
For iavntUPD2 = LBound(avntUPDatum, 2) To UBound(avntUPDatum, 2)
.Daten(.Zaehler, iavntUPD2) = avntUPDatum(iavntUPD1, iavntUPD2)
Next
End With
Next
End If
End If
Next
End If
End Sub
Private Function AnzahlSP(KW_Block_Bereich As Range, ID_Spalten As Variant, SP_Suchwerte As _
Variant) As Long
Dim dicSP As Object
Dim dicUnikate As Object
Dim avntDaten() As Variant
Dim iavntD As Long
Dim strID As String
Dim vntSP As Variant
Dim iID_Spalten As Long
' Dictionary-Objekt für SP erzeugen
Set dicSP = CreateObject("scripting.dictionary")
' Dictionary-Objekt für Unikate erzeugen
Set dicUnikate = CreateObject("scripting.dictionary")
' Textvergleich setzen
dicSP.CompareMode = vbTextCompare
' Alle gesuchten SPs für späteren vergleich einlesen
For Each vntSP In SP_Suchwerte
dicSP(vntSP) = 0
Next
' Daten in Array speichern
avntDaten() = KW_Block_Bereich.Value
' Daten zeilenweise durchlaufen
For iavntD = LBound(avntDaten, 1) To UBound(avntDaten, 1)
' Prüfen ob SP vorhanden
If dicSP.Exists(avntDaten(iavntD, 1)) Then
' ID leeren
strID = vbNullString
' Inhalte der übergebenen ID-Spalten verketten
For iID_Spalten = LBound(ID_Spalten) To UBound(ID_Spalten)
strID = strID & "_" & avntDaten(iavntD, ID_Spalten(iID_Spalten))
Next
strID = Mid$(strID, 2)
' Prüfen ob ID nicht vorhanden
If Not dicUnikate.Exists(strID) Then
' ID in Dict.-Objekt speichern und hochzählen
dicUnikate(strID) = dicUnikate(strID) + 1
End If
End If
Next
' Anzahl der Unikate zurückgeben
AnzahlSP = dicUnikate.Count
' Objektvariablen-Verweis zerstören
Set dicSP = Nothing
Set dicUnikate = Nothing
End Function
Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
' Ermittelt die letzte beschriebene Zeile
On Error Resume Next
LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious). _
_
Row
End Function
Public Function LetzteBeschriebeneSpalte(ByRef rngBereich As Range) As Long
' Ermittelt die letzte beschriebene Spalte
On Error Resume Next
LetzteBeschriebeneSpalte = rngBereich.Find("*", , xlFormulas, xlWhole, xlByColumns, _
xlPrevious).Column
End Function
Public Function DIN_KW(Datum As Date) As Byte
' Ermittelt die DIN-KW
Dim datKW As Date
datKW = 4 + Datum - Weekday(Datum, 2)
DIN_KW = (datKW - DateSerial(Year(datKW), 1, -6)) \ 7
End Function
Gibt es etwas das man unbedingt berücksichtigen muss? Oder Wessen Sollte
Grüße Lukas