Zkopíroval jsem VBA pro kopírování dat z buňky do stejného řádku jiného sloupce a změnil jsem jej tak, abych mohl změnit buňku ve sloupci F a uložit hodnotu do sloupce E, ale když to zkusím, nic se nestane. Může mi někdo říct, co dělám špatně? Chtěl bych také umístit datové razítko do sloupce G, když provedu změnu.
Doufal jsem, že také budu moci udělat totéž, když změním buňku ve sloupci I, abych ji uložil do sloupce H a označil tuto změnu datem ve sloupci J.
Jakákoli pomoc by byla velmi oceněna.
Dim xRg jako rozsah
Dim xChangeRg jako rozsah
Dim xDependRg jako rozsah
Dim xDic jako nový slovník
Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell jako rozsah
Ztlumit xHeader jako řetězec
Dim xCommText jako řetězec
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Předchozí hodnota:"
x = xDic.Keys
Pro I = 0 až UBound(xDic.Keys)
Nastavit xCell = Range(xDic.Keys(I))
Nastavit xDCell = Cells(xCell.Row, 5)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
další
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim I, J As Long
Dim xRgArea jako rozsah
On Error GoTo Label1
Pokud Target.Count > 1, pak Exit Sub
Application.EnableEvents = False
Nastavte xDependRg = Target.Dependents
Pokud xDependRg není nic, pak přejděte na Label1
Pokud ne, xDependRg není nic, pak
Nastavit xDependRg = Intersect(xDependRg, Range("F:F"))
End If
Štítek1:
Nastavit xRg = Intersect(Target, Range("F:F"))
If (Not xRg Is Nothing) A (Not xDependRg Is Nothing) Then
Nastavit xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) A (Not xDependRg Is Nothing) Potom
Nastavte xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) A (xDependRg Is Nothing) Potom
Nastavte xChangeRg = xRg
Jiný
Application.EnableEvents = True
Konec Sub
End If
xDic.RemoveAll
Pro I = 1 To xChangeRg.Areas.Count
Nastavit xRgArea = xChangeRg.Areas(I)
Pro J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Formula
další
další
Nastavit xChangeRg = nic
Nastavit xRg = nic
Nastavte xDependRg = Nic
Application.EnableEvents = True
End Sub
Doufal jsem, že také budu moci udělat totéž, když změním buňku ve sloupci I, abych ji uložil do sloupce H a označil tuto změnu datem ve sloupci J.
Jakákoli pomoc by byla velmi oceněna.
Dim xRg jako rozsah
Dim xChangeRg jako rozsah
Dim xDependRg jako rozsah
Dim xDic jako nový slovník
Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell jako rozsah
Ztlumit xHeader jako řetězec
Dim xCommText jako řetězec
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Předchozí hodnota:"
x = xDic.Keys
Pro I = 0 až UBound(xDic.Keys)
Nastavit xCell = Range(xDic.Keys(I))
Nastavit xDCell = Cells(xCell.Row, 5)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
další
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim I, J As Long
Dim xRgArea jako rozsah
On Error GoTo Label1
Pokud Target.Count > 1, pak Exit Sub
Application.EnableEvents = False
Nastavte xDependRg = Target.Dependents
Pokud xDependRg není nic, pak přejděte na Label1
Pokud ne, xDependRg není nic, pak
Nastavit xDependRg = Intersect(xDependRg, Range("F:F"))
End If
Štítek1:
Nastavit xRg = Intersect(Target, Range("F:F"))
If (Not xRg Is Nothing) A (Not xDependRg Is Nothing) Then
Nastavit xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) A (Not xDependRg Is Nothing) Potom
Nastavte xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) A (xDependRg Is Nothing) Potom
Nastavte xChangeRg = xRg
Jiný
Application.EnableEvents = True
Konec Sub
End If
xDic.RemoveAll
Pro I = 1 To xChangeRg.Areas.Count
Nastavit xRgArea = xChangeRg.Areas(I)
Pro J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Formula
další
další
Nastavit xChangeRg = nic
Nastavit xRg = nic
Nastavte xDependRg = Nic
Application.EnableEvents = True
End Sub