Hi,
I'm working on a macro that automaticly fills in some rows in some workbooks,
had a version that worked, but I'm trying to improve the macro and now I'm getting a type mismatch in 'select case' DBsht.cells(i-1,1).value
run "TrainingData" won't work.
(Had to cut some macro's, not enough place to post)
If someone can tell me why, it would be a great help.
Here the macro:
worksheet matrix:
Option Explicit
Dim DBsht As Worksheet, Ind As Long
Private Sub DBOverzicht_Click()
Start:
On Error GoTo errorhandler
Set DBSurvey = GetObject(ThisWorkbook.Path & "\Overzicht.xls")
With Windows("Overzicht.xls")
.Visible = True
.Activate
End With
Set DBSurvey = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo errorhandler
If ThisWorkbook.ReadOnly = True Then Exit Sub
If Target = Empty Then Exit Sub
If Not Intersect(Target, Columns("b:b")) Is Nothing Then
If Cells(Target.Row, Target.Column - 1).Value = Empty Then
Cells(Target.Row, Target.Column - 1).Value = GetIndex(Ind)
End If
Exit Sub
ElseIf Not Intersect(Target, Columns("t:z")) Is Nothing Then
Set DBsht = Workbooks("TL.xls").Worksheets("TL")
ElseIf Not Intersect(Target, Columns("an:at")) Is Nothing Then
Set DBsht = Workbooks("ASF.xls").Worksheets("ASF")
ElseIf Not Intersect(Target, Columns("bh:bn")) Is Nothing Then
Set DBsht = Workbooks("TO.xls").Worksheets("TO")
ElseIf Not Intersect(Target, Columns("cb:ch")) Is Nothing Then
Set DBsht = Workbooks("TB.xls").Worksheets("TB")
ElseIf Not Intersect(Target, Columns("cv:db")) Is Nothing Then
Set DBsht = Workbooks("MO.xls").Worksheets("MO")
ElseIf Not Intersect(Target, Columns("dp:dv")) Is Nothing Then
Set DBsht = Workbooks("VT.xls").Worksheets("VT")
ElseIf Not Intersect(Target, Columns("ej:ep")) Is Nothing Then
Set DBsht = Workbooks("PT.xls").Worksheets("PT")
ElseIf Not Intersect(Target, Columns("fd:fj")) Is Nothing Then
Set DBsht = Workbooks("B.xls").Worksheets("B")
ElseIf Not Intersect(Target, Columns("fx:gd")) Is Nothing Then
Set DBsht = Workbooks("GC.xls").Worksheets("GC")
ElseIf Not Intersect(Target, Columns("gr:gx")) Is Nothing Then
Set DBsht = Workbooks("PO.xls").Worksheets("PO")
ElseIf Not Intersect(Target, Columns("hl:hr")) Is Nothing Then
Set DBsht = Workbooks("ZC.xls").Worksheets("ZC")
ElseIf Not Intersect(Target, Columns("if:il")) Is Nothing Then
Set DBsht = Workbooks("LME").Worksheets("LME")
Else
Exit Sub
End If
Run "GetColumn", Target, DBsht
errorhandler:
End Sub
Private Function GetIndex(Ind As Long) As Long
Ind = Application.WorksheetFunction.Max(Range("Index")) + 1
GetIndex = Ind
End Function
in module:
Option Explicit
Dim aWorkbook As Workbook, FCount As Long
Public DBSurvey As Object, Response As Variant
Public Const Folder As String = "\DBsDoelgroepen\"
Dim i As Long, aData As Variant, c As Integer, z As Integer
Dim StartW1 As String, StartW2 As String
Dim StartWeek As String, sEdu As String, sImp As String
Dim CountW As Integer, Dept As String, StartValue As String
Dim x As Integer, sO As Integer, sI As Integer, Ih As Integer
Dim s As Integer, Wt As Integer, Wi As Integer, t As Integer
Private Sub GetColumn(Target As Range, DBsht As Worksheet)
Select Case Target.Column
Case 20, 40, 60, 80, 100, 120, 140, 160, 180, 200, 220, 240
Dept = "GA"
Case 21, 41, 61, 81, 101, 121, 141, 161, 181, 201, 221, 241
Dept = "GB"
Case 22, 42, 62, 82, 102, 122, 142, 162, 182, 202, 222, 242
Dept = "GC"
Case 23, 43, 63, 83, 103, 123, 143, 163, 183, 203, 223, 243
Dept = "LOG"
Case 24, 44, 64, 84, 104, 124, 144, 164, 184, 204, 224, 244
Dept = "ENG"
Case 25, 45, 65, 85, 105, 125, 145, 165, 185, 205, 225, 245
Dept = "ESDIC"
Case 26, 46, 66, 86, 106, 126, 146, 166, 186, 206, 226, 246
Dept = "ECG"
End Select
Run "Main", Target, Dept, DBsht
End Sub
Private Sub Main(Target As Range, Dept As String, DBsht As Worksheet)
With Application
.StatusBar = "Writing data..."
.ScreenUpdating = False
End With
DBsht.EnableCalculation = False
Select Case Dept
Case "GA"
sO = 7
sI = 4
s = 13
Case "GB"
sO = 8
sI = 5
s = 14
Case "GC"
sO = 9
sI = 6
s = 15
Case "LOG"
sO = 10
sI = 7
s = 16
Case "ENG"
sO = 11
sI = 8
s = 17
Case "ESDIC"
sO = 12
sI = 9
s = 18
Case "ECG"
sO = 13
sI = 10
s = 19
End Select
sEdu = Cells(Target.Row, Target.Column - sO).Value
StartW1 = Left(sEdu, Len(sEdu) - 3) & UCase(Chr(87)) & Right(sEdu, Len(sEdu) - 3)
sImp = Cells(Target.Row, Target.Column - sI).Value
StartW2 = Left(sImp, Len(sImp) - 3) & UCase(Chr(87)) & Right(sImp, Len(sImp) - 3)
aData = DBsht.Range("Data").Columns(1)
For i = LBound(aData) + DBsht.Range("HData").Row To _
UBound(aData) + DBsht.Range("HData").Row
If DBsht.Cells(i, 1) = Empty Then Exit For
If IsError(DBsht.Cells(i, 3).Value) = True Then
DBsht.Rows(i).ClearContents
Exit For
ElseIf Cells(Target.Row, 1).Value = DBsht.Cells(i, 2).Value Then
If Cells(Target.Row, 2).Value = DBsht.Cells(i, 3).Value Then
If Dept = DBsht.Cells(i, 5).Value Then
DBsht.Rows(i).ClearContents
Exit For
Else
End If
End If
End If
Next
x = 0
Do Until x = 4
Select Case DBsht.Cells(i - 1, 1).Value
Case Is = "M"
StartValue = "N"
Run "TrainingData", Target, DBsht, StartValue, i, s, Dept
StartWeek = StartW1
Run "TrainingValues", StartValue, Target, DBsht, i, Dept, StartWeek
Case Is = "N"
StartValue = "Y"
Run "TrainingData", Target, DBsht, StartValue, i, s, Dept
StartWeek = StartW1
Run "TrainingValues", StartValue, Target, DBsht, i, Dept, StartWeek
Case Is = "Y"
StartValue = "I"
Run "TrainingData", Target, DBsht, StartValue, i, s, Dept
StartWeek = StartW2
Run "ImplementValues", StartValue, Target, DBsht, i, Dept, StartWeek
Case Is = "I"
StartValue = "M"
Run "TrainingData", Target, DBsht, StartValue, i, s, Dept
StartWeek = StartW2
Run "ImplementValues", StartValue, Target, DBsht, i, Dept, StartWeek
Case Else
StartValue = "N"
Run "TrainingData", Target, DBsht, StartValue, i, s, Dept
StartWeek = StartW1
Run "TrainingValues", StartValue, Target, DBsht, i, Dept, StartWeek
End Select
i = i + 1
If DBsht.Cells(i, 1).Value <> Empty Then DBsht.Rows(i).ClearContents
x = x + 1
Loop
DBsht.EnableCalculation = True
With Application
.Calculate
.StatusBar = False
End With
End Sub
Private Sub TrainingValues(StartValue As String, Target As Range, _
DBsht As Worksheet, i As Integer, _
Dept As String, StartWeek As String)
Application.ScreenUpdating = False
For c = 1 To DBsht.Range("HData").Cells.Count
If DBsht.Range("HData").Cells(1, c).Value = StartWeek Then
Exit For
End If
Next c
Select Case Dept
Case "GA"
Wt = 2
t = 8
Case "GB"
Wt = 3
t = 9
Case "GC"
Wt = 4
t = 10
Case "LOG"
Wt = 5
t = 11
Case "ENG"
Wt = 6
t = 12
Case "ESDIC"
Wt = 7
t = 13
Case "ECG"
Wt = 8
t = 14
End Select
Select Case StartValue
Case "N"
'De kruising van de juiste rij en kolom wordt gevormd in de database en het aantal uren
'training wordt meegegeven, en herhaald tot het aantal cellen het aantal weken in Matrix is
CountW = Cells(Target.Row, Target.Column - Wt).Value
z = 0
Do Until z = CountW
DBsht.Cells(i, c).FormulaR1C1 = "='[" & ThisWorkbook.Name & "]Matrix'!R" & (Target.Row) & "C" & (Target.Column - t) & ""
c = c + 1
z = z + 1
Loop
Case "Y"
'De formule voor het procent van de doelgroep wordt in de cellen geschreven en herhaald voor
'het aantal weken in Matrix
CountW = Cells(Target.Row, Target.Column - Wt).Value
z = 0
Do Until z = CountW
DBsht.Cells(i, c).FormulaR1C1 = _
"=PRODUCT(NumGrp" & (Dept) & ",'[" & ThisWorkbook.Name & "]Matrix'!R" & (Target.Row) & "C" & (Target.Column) & ")/PRODUCT(100,'[" & ThisWorkbook.Name & "]Matrix'!R" & (Target.Row) & "C" & (Target.Column - Wt) & ")"
c = c + 1
z = z + 1
Loop
End Select
Exit Sub
errorhandler:
MsgBox "Er heeft een fout plaatsgevonden, de data kan niet worden gekopieerd."
End Sub
Private Sub TrainingData(Target As Range, DBsht As Worksheet, i As Long, _
StartValue As String, s As Integer, Dept As String)
With DBsht
.Cells(i, 1).Value = StartValue
.Cells(i, 2).FormulaR1C1 = "='[" & ThisWorkbook.Name & "]Matrix'!R" & (Target.Row) & "C1"
.Cells(i, 3).FormulaR1C1 = "='[" & ThisWorkbook.Name & "]Matrix'!R" & (Target.Row) & "C2"
.Cells(i, 4).FormulaR1C1 = "='[" & ThisWorkbook.Name & "]Matrix'!R" & (Target.Row) & "C5"
.Cells(i, 5).Value = Dept
.Cells(i, 6).FormulaR1C1 = "='[" & ThisWorkbook.Name & "]Matrix'!R" & (Target.Row) & "C" & (Target.Column - s) & ""
End With
End Sub
Bookmarks