Cómo unir estos dos códigos en uno solo

Necesito que me ayudes a unir estos dos códigos:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler
  Select Case Target.Column
  Case 3, 4, 5
       On Error Resume Next
        Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitHandler
    If rngDV Is Nothing Then GoTo exitHandler
        If Intersect(Target, rngDV) Is Nothing Then
    Else
        Application.EnableEvents = False
        newVal = Target.Value
        Application.Undo
        oldVal = Target.Value
        Target.Value = newVal
        If oldVal <> "" Then
          If newVal <> "" Then
            Target.Value = oldVal _
              & ", " & newVal
          End If
        End If
    End If
End Select
exitHandler:
  Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim rngFechas As Range
      Set rngFechas = Range("I:J") 'Muestra el calendario en cualquier celda de la columna A
        If Union(Target, rngFechas).Address = rngFechas.Address Then _
        Call abrir_calendario
    If Not Intersect(Target, Columns("F")) Is Nothing Then
        Set h = Sheets("Auxiliar")
        For Each c In Target
            If c.Value <> "" Then
                u = h.UsedRange.Rows(h.UsedRange.Rows.Count).Row
                Set b = h.Range("B2:E" & u).Find(c.Value, lookat:=xlWhole)
                If Not b Is Nothing Then
                    Cells(c.Row, "B") = h.Cells(1, b.Column)
                End If
            Else
                Cells(c.Row, "B") = ""
            End If
        Next
    End If
    If Not Intersect(Target, Columns("F")) Is Nothing Then
        Set h = Sheets("Auxiliar")
        For Each c In Target
            If c.Value <> "" Then
                u = h.UsedRange.Rows(h.UsedRange.Rows.Count).Row
                Set b = h.Range("X2:Z" & u).Find(c.Value, lookat:=xlWhole)
                If Not b Is Nothing Then
                    Cells(c.Row, "K") = h.Cells(1, b.Column)
                End If
            Else
                Cells(c.Row, "K") = ""
            End If
        Next
    End If
    If Target.Column = 2 And Target.Row > 1 Then
        If Target.Row = 2 Then
            Sheets("Datos").Cells(Target.Row, 1).Value = 1
        Else
            Sheets("Datos").Cells(Target.Row, 1).Value = Sheets("Datos").Cells(Target.Row - 1, 1).Value + 1
        End If
    End If
End Sub

1 Respuesta

Respuesta
2

Te anexo la macro unida

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Select Case Target.Column
        Case 3, 4, 5
            If Target.Count > 1 Then GoTo exitHandler
            On Error Resume Next
            Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
            On Error GoTo exitHandler
            If rngDV Is Nothing Then GoTo exitHandler
            If Intersect(Target, rngDV) Is Nothing Then
                '
            Else
                Application.EnableEvents = False
                newVal = Target.Value
                Application.Undo
                oldVal = Target.Value
                Target.Value = newVal
                If oldVal <> "" Then
                    If newVal <> "" Then
                        Target.Value = oldVal _
                        & ", " & newVal
                    End If
                End If
            End If
            '
        Case Else
            '
            Application.ScreenUpdating = False
            Dim rngFechas As Range
            Set rngFechas = Range("I:J") 'Muestra el calendario en cualquier celda de la columna A
            If Union(Target, rngFechas).Address = rngFechas.Address Then _
                Call abrir_calendario
            If Not Intersect(Target, Columns("F")) Is Nothing Then
                Set h = Sheets("Auxiliar")
                For Each c In Target
                    If c.Value <> "" Then
                        u = h.UsedRange.Rows(h.UsedRange.Rows.Count).Row
                        Set b = h.Range("B2:E" & u).Find(c.Value, lookat:=xlWhole)
                        If Not b Is Nothing Then
                            Cells(c.Row, "B") = h.Cells(1, b.Column)
                        End If
                    Else
                        Cells(c.Row, "B") = ""
                    End If
                Next
            End If
            If Not Intersect(Target, Columns("F")) Is Nothing Then
                Set h = Sheets("Auxiliar")
                For Each c In Target
                    If c.Value <> "" Then
                        u = h.UsedRange.Rows(h.UsedRange.Rows.Count).Row
                        Set b = h.Range("X2:Z" & u).Find(c.Value, lookat:=xlWhole)
                        If Not b Is Nothing Then
                            Cells(c.Row, "K") = h.Cells(1, b.Column)
                        End If
                    Else
                        Cells(c.Row, "K") = ""
                    End If
                Next
            End If
            If Target.Column = 2 And Target.Row > 1 Then
                If Target.Row = 2 Then
                    Sheets("Datos").Cells(Target.Row, 1).Value = 1
                Else
                    Sheets("Datos").Cells(Target.Row, 1).Value = Sheets("Datos").Cells(Target.Row - 1, 1).Value + 1
                End If
            End If
    End Select
    '
exitHandler:
  Application.EnableEvents = True
End Sub

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas