11. december 2009 - 11:08Der er
5 kommentarer og 1 løsning
Sammenskrivning af to macroer
Hejsa
Er der en ørn som kan sammenskrive disse to macroer til en:
1) Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim Descrip As String Dim thisrow As String Dim r As Double Dim c As Double
c = Selection.Columns.Count r = Selection.Rows.Count thisrow = Target.row
If c > 1 Or r > 1 Or Target.column <> 10 Or Target.Cells.Count <> 1 Then Exit Sub End If
If IsError(Application.VLookup(Range("J" & thisrow).Value, Worksheets("Projects").Range("$B$3:$G$2000"), 6, False)) And Target.column = 10 Then Range("K" & thisrow).Value = "" Exit Sub End If
If Target.Cells.Count = 1 Then Descrip = Application.VLookup(Range("J" & thisrow).Value, Worksheets("Projects").Range("$B$3:$G$2000"), 6, False) Range("K" & thisrow).Value = Descrip End If
End Sub
----------------------------------------------------------------- 2) Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim Competences As String Dim thisrow As String Dim r As Double Dim c As Double
c = Selection.Columns.Count r = Selection.Rows.Count thisrow = Target.row
If c > 1 Or r > 1 Or Target.column <> 6 Or Target.Cells.Count <> 1 Then Exit Sub End If
If IsError(Application.VLookup(Range("G" & thisrow).Value, Worksheets("Resource Pool").Range("$B$3:$C$2000"), 2, False)) And Target.column = 3 Then Range("H" & thisrow).Value = "" Exit Sub End If
If Target.Cells.Count = 1 Then Descrip = Application.VLookup(Range("G" & thisrow).Value, Worksheets("Projects").Range("$B$3:$C$2000"), 2, False) Range("H" & thisrow).Value = Competences End If
End Sub --------------------------------------------------
Hvis de to koder er ok, kan du så ikke bruge løsningen fra tidligere spørgsmål http://www.eksperten.dk/spm/895134 Put de 2 kodestumper i 2 subs, og kald de 2 subs i Worksheet_Change
Private Sub Worksheet_Change(ByVal Target As Excel.Range) Call KolonneJ Call KolonneG End sub
'1) flyttes til et modul Sub KolonneJ() Dim Descrip As String Dim thisrow As String Dim r As Double Dim c As Double
c = Selection.Columns.Count r = Selection.Rows.Count thisrow = Target.row
If c > 1 Or r > 1 Or Target.column <> 10 Or Target.Cells.Count <> 1 Then Exit Sub End If
If IsError(Application.VLookup(Range("J" & thisrow).Value, Worksheets("Projects").Range("$B$3:$G$2000"), 6, False)) And Target.column = 10 Then Range("K" & thisrow).Value = "" Exit Sub End If
If Target.Cells.Count = 1 Then Descrip = Application.VLookup(Range("J" & thisrow).Value, Worksheets("Projects").Range("$B$3:$G$2000"), 6, False) Range("K" & thisrow).Value = Descrip End If
End Sub
'2) flyttes til samme modul Sub KolonneG() Dim Competences As String Dim thisrow As String Dim r As Double Dim c As Double
c = Selection.Columns.Count r = Selection.Rows.Count thisrow = Target.row
If c > 1 Or r > 1 Or Target.column <> 6 Or Target.Cells.Count <> 1 Then Exit Sub End If
If IsError(Application.VLookup(Range("G" & thisrow).Value, Worksheets("Resource Pool").Range("$B$3:$C$2000"), 2, False)) And Target.column = 3 Then Range("H" & thisrow).Value = "" Exit Sub End If
If Target.Cells.Count = 1 Then Descrip = Application.VLookup(Range("G" & thisrow).Value, Worksheets("Projects").Range("$B$3:$C$2000"), 2, False) Range("H" & thisrow).Value = Competences End If
Prøv at lægge dem i 2 moduler, så der ikke er noget der bliver rodet sammen.
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
