|
Vielleicht kann der Code weiterhelfen. In der xlsm-Datei sind zwei Module mit folgendem Code gespeichert:
Modul "Start"
Option Explicit
Private Sub Auto_Open()
Dim datas As Workbook
Dim datas_range As String
Dim i As Long
Dim this_wb As Workbook
Set this_wb = ActiveWorkbook
Set datas = Workbooks.Open(ActiveWorkbook.Path & "\checklist_data.xls")
datas.Sheets("data").Activate
Range("A1").Select
ActiveCell.CurrentRegion.Select
datas_range = Selection.Address
Dim datas_range_array() As String
datas_range_array = Split(datas_range, ":")
datas_range = datas_range_array(1)
datas_range_array = Split(datas_range, "$")
Dim last_col As String
Dim last_row As String
last_col = datas_range_array(1)
last_row = datas_range_array(2)
Dim first_col As String
Dim first_row As String
first_col = "A"
first_row = "2"
datas_range = Replace(datas_range, "$", "")
Dim anz_cols As Integer
Dim anz_rows As Integer
anz_cols = Asc(last_col) - Asc(first_col)
anz_rows = last_row - first_row
Dim data_names() As Variant
Dim data_type() As Variant
ReDim data_names(Asc(first_col) To Asc(last_col), 1 To 2)
ReDim data_type(1 To 4)
Dim farben() As String
ReDim farben(Asc(first_col) To Asc(last_col))
For i = Asc(first_col) To Asc(last_col)
data_names(i, 1) = Range(Chr(i) & first_row).Value
If IsNumeric(Range(Chr(i) & first_row - 1).Value) = True Then
data_names(i, 2) = Range(Chr(i) & first_row - 1).Value
data_type(Range(Chr(i) & first_row - 1).Value) = data_type(Range(Chr(i) & first_row - 1).Value) & i & ","
Else
data_names(i, 2) = "-"
End If
Next i
Dim data() As Variant
ReDim data(Asc(first_col) To Asc(last_col))
Dim r As Integer
For i = Asc(first_col) To Asc(last_col)
If IsNumeric(Range(Chr(i) & first_row - 1).Value) Then
For r = first_row + 1 To last_row
If Range(Chr(i) & r).Value <> "" Then
data(i) = data(i) & r & ","
farben(i) = Range(Chr(i) & first_row).Interior.Color
End If
Next r
End If
Next i
Dim typ_col() As String
Dim atm_col As String
Dim atm_data() As String
Dim d As Integer
Dim atm_anz As Integer
Dim atm_value As String
StartForm.Option_Art.AddItem "-"
StartForm.Option_Sicherstellung.AddItem "-"
StartForm.Option_Checkbox.AddItem "-"
For i = 1 To 4
typ_col = Split(data_type(i), ",")
For r = UBound(typ_col) - 1 To 0 Step -1
If i = 1 Then
If data(typ_col(r)) <> "" Then
atm_col = Chr(typ_col(r)) 'col (letter)
atm_data = Split(data(typ_col(r)), ",")
atm_anz = UBound(atm_data) - 1
this_wb.Sheets("checklist").Activate
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("11:11").RowHeight = 5
For d = UBound(atm_data) - 1 To 0 Step -1
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A11:H11").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A11:B11").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Bold = True
datas.Sheets("data").Activate
atm_value = Range(first_col & atm_data(d)).Value
this_wb.Sheets("checklist").Activate
Range("C11") = atm_value
Rows("11:11").RowHeight = 13.5
Range("A11:H11").Select
Selection.Interior.Color = farben(typ_col(r))
Next d
Range("A11") = data_names(typ_col(r), 1)
datas.Sheets("data").Activate
End If
End If
Next r
If i <> 1 Then
atm_data = Split(data_type(i), ",")
For d = 0 To UBound(atm_data) - 1
datas.Sheets("data").Activate
atm_value = Range(Chr(atm_data(d)) & first_row)
this_wb.Sheets("checklist").Activate
If i = 2 Then
StartForm.Option_Art.AddItem atm_value
End If
If i = 3 Then
StartForm.Option_Sicherstellung.AddItem atm_value
End If
If i = 4 Then
StartForm.Option_Checkbox.AddItem atm_value
End If
Next d
End If
Next i
StartForm.Option_Art.ListIndex = 0
StartForm.Option_Sicherstellung.ListIndex = 0
StartForm.Option_Checkbox.ListIndex = 0
datas.Close
this_wb.Sheets("checklist").Activate
Range("A1").Select
StartForm.Show
End Sub
Und das Modul "Startinput"
Sub start_form()
Dim datas As Workbook
Dim datas_range As String
Dim i As Long
Dim this_wb As Workbook
Set this_wb = ActiveWorkbook
Set datas = Workbooks.Open(ActiveWorkbook.Path & "\checklist_data.xls")
datas.Sheets("data").Activate
Range("A1").Select
ActiveCell.CurrentRegion.Select
datas_range = Selection.Address
Dim datas_range_array() As String
datas_range_array = Split(datas_range, ":")
datas_range = datas_range_array(1)
datas_range_array = Split(datas_range, "$")
Dim last_col As String
Dim last_row As String
last_col = datas_range_array(1)
last_row = datas_range_array(2)
Dim first_col As String
Dim first_row As String
first_col = "A"
first_row = "2"
datas_range = Replace(datas_range, "$", "")
Dim anz_cols As Integer
Dim anz_rows As Integer
anz_cols = Asc(last_col) - Asc(first_col)
anz_rows = last_row - first_row
' art = 2
Dim art_id As String
art_id = StartForm.Option_Art
Dim ii As Integer
Dim soll_punkt As String
Dim iii As Integer
Dim datas_range1 As String
Dim datas_range_array1() As String
datas.Sheets("data").Activate
If art_id <> "-" Then
For i = Asc(first_col) To Asc(last_col)
If Range(Chr(i) & first_row).Value = art_id Then
For ii = first_row To last_row
If Range(Chr(i) & ii).Value = "x" Then
soll_punkt = Range(first_col & ii).Value
this_wb.Sheets("checklist").Activate
Range("Daten").Select
datas_range1 = Selection.Address
datas_range_array1 = Split(datas_range1, ":")
datas_range1 = datas_range_array1(1)
datas_range_array1 = Split(datas_range1, "$")
last_row1 = datas_range_array1(2)
For iii = 11 To last_row1
If Range("C" & iii).Value = soll_punkt Then
Range("D" & iii) = "x"
End If
Next iii
datas.Sheets("data").Activate
End If
Next ii
End If
Next i
End If
' sicherstellung = 3
Dim sicherstellung_id As String
sicherstellung_id = StartForm.Option_Sicherstellung
datas.Sheets("data").Activate
If sicherstellung_id <> "-" Then
For i = Asc(first_col) To Asc(last_col)
If Range(Chr(i) & first_row).Value = sicherstellung_id Then
For ii = first_row To last_row
If Range(Chr(i) & ii).Value = "x" Then
soll_punkt = Range(first_col & ii).Value
this_wb.Sheets("checklist").Activate
Range("Daten").Select
datas_range1 = Selection.Address
datas_range_array1 = Split(datas_range1, ":")
datas_range1 = datas_range_array1(1)
datas_range_array1 = Split(datas_range1, "$")
last_row1 = datas_range_array1(2)
For iii = 11 To last_row1
If Range("C" & iii).Value = soll_punkt Then
Range("D" & iii) = "x"
End If
Next iii
datas.Sheets("data").Activate
End If
Next ii
End If
Next i
End If
' checkbox = 4
Dim checkbox_id As String
checkbox_id = StartForm.Option_Checkbox
datas.Sheets("data").Activate
If checkbox_id <> "-" Then
For i = Asc(first_col) To Asc(last_col)
If Range(Chr(i) & first_row).Value = checkbox_id Then
For ii = first_row To last_row
If Range(Chr(i) & ii).Value = "x" Then
soll_punkt = Range(first_col & ii).Value
this_wb.Sheets("checklist").Activate
Range("Daten").Select
datas_range1 = Selection.Address
datas_range_array1 = Split(datas_range1, ":")
datas_range1 = datas_range_array1(1)
datas_range_array1 = Split(datas_range1, "$")
last_row1 = datas_range_array1(2)
For iii = 11 To last_row1
If Range("C" & iii).Value = soll_punkt Then
Range("D" & iii) = "x"
End If
Next iii
datas.Sheets("data").Activate
End If
Next ii
End If
Next i
End If
datas.Close
this_wb.Sheets("checklist").Activate
StartForm.Hide
Range("A1").Select
End Sub
|