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 de Dante Amor
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
.
