Avatar billede Simonjulandreasen Nybegynder
29. januar 2015 - 10:47 Der er 4 kommentarer

Sammenfeltning af to VBA koder

Hej jeg har hjælp med at sætte 2 VBA koder sammen. De funger enkeltvis  men når de er i samme sheet går det galt.

koderne er nedenfor - jeg håber i kan hjælpe.

---------------------
Kode 1

' koden angiver today i ´kolonne G når der bliver skrevet i række B
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim rCell As Range
    Dim rChange As Range
   
    On Error GoTo ErrHandler
    Set rChange = Intersect(Target, Range("B:B"))
    If Not rChange Is Nothing Then
        Application.EnableEvents = False
        For Each rCell In rChange
            If rCell > "" Then
                With rCell.Offset(0, 5)
                    .Value = Now
                    .NumberFormat = "m/d/yyyy"
                End With
            Else
                rCell.Offset(0, 5).Clear
            End If
        Next
    End If
ExitHandler:
    Set rCell = Nothing
    Set rChange = Nothing
    Application.EnableEvents = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
-----------------
Kode 2
'angiver dato i kolonne J hvis der står "i" eller "implemented" i kolonne K. 

Private Sub Worksheet_Changes(ByVal Target As Range)
If Target.Column = 10 Then
  If Target = "" Then Range("K" & Target.Row) = ""
  If Target = "implemented" Or Target = "i" Then _
    Range("K" & Target.Row) = Date
End If
End Sub
-----

Som sagt virker koderne ikke når de begge er i samme sheet men wiker godt når der kun er en af dem i sheetet.

Så jeg tænkte om de kunne skrives sammen?
Avatar billede finb Ekspert
29. januar 2015 - 13:16 #1
Sub 3:
Call sub 1
Call sub 2
End sub 3
Avatar billede store-morten Ekspert
29. januar 2015 - 14:32 #2
Prøv:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Kode 1

Kode 2

End Sub
Avatar billede kabbak Professor
29. januar 2015 - 19:46 #3
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim rCell As Range
    Dim rChange As Range

If Target.Column = 10 Then
  If Target = "" Then Range("K" & Target.Row) = ""
  If Target = "implemented" Or Target = "i" Then _
    Range("K" & Target.Row) = Date
End If


    On Error GoTo ErrHandler
    Set rChange = Intersect(Target, Range("B:B"))
    If Not rChange Is Nothing Then
        Application.EnableEvents = False
        For Each rCell In rChange
            If rCell > "" Then
                With rCell.Offset(0, 5)
                    .Value = Now
                    .NumberFormat = "m/d/yyyy"
                End With
            Else
                rCell.Offset(0, 5).Clear
            End If
        Next
    End If
ExitHandler:
    Set rCell = Nothing
    Set rChange = Nothing
    Application.EnableEvents = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
-----------------
Avatar billede store-morten Ekspert
29. januar 2015 - 20:54 #4
Uden forklaring:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

On Error GoTo ErrHandler
Application.EnableEvents = False

If Target.Column = 10 Then
If Target = "" Then Target.Offset(0, 1) = ""
If Target = "implemented" Then Target.Offset(0, 1) = Date
If Target = "i" Then Target.Offset(0, 1) = Date
End If

If Target.Column = 2 Then
If Target = "" Then Target.Offset(0, 5) = ""
If Target >= "" Then Target.Offset(0, 5) = Date
End If

Application.EnableEvents = True

Exit Sub

ErrHandler:
MsgBox Err.Description
Application.EnableEvents = True

End Sub


Med forklaring:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

On Error GoTo ErrHandler
'Skærmopdatering slås fra
Application.EnableEvents = False

'Når der bliver skrevet i række K
If Target.Column = 10 Then
    'K tom slettes i kolonne J
If Target = "" Then Target.Offset(0, 1) = ""
    'K "implemented" skrives today i kolonne J
If Target = "implemented" Then Target.Offset(0, 1) = Date
    'K "i" skrives today i kolonne J
If Target = "i" Then Target.Offset(0, 1) = Date
End If

'Når der bliver skrevet i række B
If Target.Column = 2 Then
    'B tom slettes i kolonne G
If Target = "" Then Target.Offset(0, 5) = ""
    'B ikke tom skrives today i kolonne G
If Target >= "" Then Target.Offset(0, 5) = Date
End If

'Skærmopdatering slås til
Application.EnableEvents = True

Exit Sub

ErrHandler:
MsgBox Err.Description
    'Skærmopdatering slås til efter en fejl
Application.EnableEvents = True

End Sub
Avatar billede Ny bruger Nybegynder

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.

Loading billede Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester