+ Reply to Thread
Results 1 to 3 of 3

type mismatch

  1. #1
    Registered User
    Join Date
    04-12-2006
    Posts
    25

    type mismatch

    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

  2. #2
    Forum Contributor colofnature's Avatar
    Join Date
    05-11-2006
    Location
    -
    MS-Off Ver
    -
    Posts
    301
    In your call to run "TrainingData" you've got StartValue & i the wrong way round:

    Run "TrainingData", ... StartValue, i, ...

    Private Sub TrainingData( ... i As Long, StartValue As String, ... )


    HTH
    Col
    If you give someone a program, you will frustrate them for a day; if you teach them how to program, you will frustrate them for a lifetime.

  3. #3
    Registered User
    Join Date
    04-12-2006
    Posts
    25
    Yep,now it's working,

    Thanks Colofnature

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1