Mein erster Quellcode

Private Sub btauffuellen_Click()
Dim zielDatei As Workbook
Dim quellDatei As Workbook
Dim dateiName As String
Dim sheetName As String
Dim row As Integer
Dim col As Integer
Dim maxRow As Integer
Dim maxCol As Integer
Dim aufgabenVorhanden As Boolean
Dim aufgaben As Variant
Dim aufgabenPunkte() As Variant
Dim resVar As Variant
Dim maxquellRow As Integer
Dim maxTeam As Integer
Dim team As Integer
Dim lastDestRow As Integer
Set zielDatei = ActiveWorkbook
'Abschalten der Warnmeldungen und der Screenaktualisierung
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Autofilter ausschalten
Selection.AutoFilter
'Bereinigen der Zieldatei
zielDatei.Sheets("Aufgaben").Range("A6:I200").Delete
'Auswählen der Tabelle "Team"
Sheets("Team").Select
Sheets("Team").Range("A1").Select
'Feststellung wieviel Zeilen die Teamliste hat
maxTeam = ActiveSheet.Cells.Find(What:="*", After:=ActiveSheet.Range("A1"), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
For team = 1 To maxTeam - 6 Step 1
'Auslesen der Dateinamen ...
Sheets("Team").Select
Sheets("Team").Range("A1").Select
ActiveCell.Offset(team, 0).Select
'Falls die die betroffene Person im gleichen Verzeichnis keine Aufgabenliste hat kommt die Fehlermeldung
' "Die Datei aufgaben_TEAMNAME.xls liegt nicht im gleichen Verzeichnis,
'ansonsten wie die Excelarbeitsmappe aufgaben_NAME.xls (Quelldatei) geöffnet
dateiName = ActiveCell.Value
If Dir(ThisWorkbook.Path & "\aufgaben_" & dateiName & ".xls") = "" Then
MsgBox ("Die Datei aufgaben_" & dateiName & ".xls liegt nicht in dem gleichen Verzeichnis wie die Zieldatei"), vbCritical, "Datenbank nicht gefunden!"
Exit Sub
Else
Workbooks.Open Filename:=ThisWorkbook.Path & "\aufgaben_" & dateiName & ".xls"
End If
'Aktivierung der Quelldatei
Set quellDatei = ActiveWorkbook
ActiveSheet.Range("D7").Select
aufgabenVorhanden = False
'Wenn Aufgaben vorhanden sind...
If ActiveCell <> "" And ActiveCell.Offset(0, 1) <> "" Then
aufgabenVorhanden = True
'vor Beginn die Quelldatei aktivieren zum einlesen...
quellDatei.Activate
ActiveSheet.Range("A7").Select
sheetName = ActiveSheet.Name
'Maximale Anzahl Spalten und Zeilen...
maxCol = 5
maxRow = ActiveSheet.Cells.Find(What:="*", After:=ActiveSheet.Range("A1"), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row - 6
'Arraygröße bestimmen...
ReDim aufgabenPunkte(maxRow, maxCol)
'Einlesen der Daten in ein Array für das spätere Auslesen in die Aufgaben_Team.xls
For row = 0 To maxRow - 1 Step 1
'Jede Zelle in der Zeile wird in das Array kopiert...
For col = 0 To maxCol Step 1
'Zelleninhalt dem Array hinzufügen...
resVar = ActiveCell.Offset(row, col).Value
aufgabenPunkte(row, col) = resVar
Next col
'nächste Zeile kopieren
Next row
Else
MsgBox ("Die Datei aufgaben_" & dateiName & ".xls enthält keine Daten"), vbCritical, "Datenbank enthält keine Daten!"
Exit Sub
End If
'Nach dem Auslesen der Aufgaben - Datei schließen...
quellDatei.Close
'Zieldatei wieder aktivieren...
zielDatei.Sheets("Aufgaben").Select
If aufgabenVorhanden Then
lastDestRow = ActiveSheet.Cells.Find(What:="*", After:=ActiveSheet.Range("A1"), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
ActiveSheet.Range("A1").Select
ActiveCell.Offset(lastDestRow, 0).Select
For row = 0 To maxRow - 1 Step 1
'Jede Zelle in der Zeile wird in das Array kopiert...
For col = 0 To maxCol Step 1
'Zelleninhalt dem Array hinzufügen...
ActiveCell.Offset(row, col).Value = aufgabenPunkte(row, col)
Next col
'Name des Teammitglieds wird in Spalte neben der AktivenZelle geschrieben
ActiveCell.Offset(row, col).Value = dateiName
'nächste Zeile kopieren
Next row
End If
Next team
zielDatei.Sheets("Aufgaben").Select
'Formatierung der Tabelle ("Aufgaben")
'Formatierung betrifft folgend Dinge:
'Spaltenbreite, Rahmen,Schriftart und Schriftgröße...
Columns("A:A").Select
Selection.ColumnWidth = 10.71
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("B:B").Select
Selection.ColumnWidth = 14.29
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("C:C").Select
Selection.ColumnWidth = 22.43
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("D:D").Select
Selection.ColumnWidth = 181
Columns("E:E").Select
Selection.ColumnWidth = 10.71
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("F:F").Select
With Selection.Font
.Name = "Wingdings"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("F1,F5").Select
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("F:G").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.Select
With Selection.Font
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Rows("1:4").Select
Range("A4").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("E1:F3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Auf Seite automatisch anpassen, Querformat einrichten etc.
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 50
.PrintErrors = xlPrintErrorsDisplayed
End With
'Druckbereich festlegen
maxquellRow = ActiveSheet.Cells.Find(What:="*", After:=ActiveSheet.Range("A1"), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
ActiveSheet.PageSetup.PrintArea = "$A$1:$G$" & maxquellRow
'Einschalten des Autofilters
Range("A5:G5").Select
Selection.AutoFilter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub