时间戳

首页 > 解决方案 > 如何提取（行和列的第一个单元格）修改后的单元格放入数组，excel vba？

excel - 如何提取（行和列的第一个单元格）修改后的单元格放入数组，excel vba？

问题描述

下面的代码记录工作表的变化（取决于 Worksheet_Change ）并将另一张工作表“记录”到多个单元格上。该代码完美无缺，但我需要对其进行调整以获取行和列的第一个单元格的值以放入代码数组的这一部分， 例如，如果更改的值为 E4、D5，我想放置在数组中，下一条信息“E1”，“D1”“A4”，“A5”

sh.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.name)

我试过Target.EntireRow.Cells(1) and Target.EntireColumn.Cells(1)了，但它不可靠，并且不适用于多细胞。任何帮助将不胜感激。 在此处输入图像描述 这是完整的代码：

Private Sub Worksheet_Change(ByVal Target As Range)

Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
 Dim sh As Worksheet: Set sh = Sheets("Log")
 Dim UN As String: UN = Application.UserName
 
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 
 If Target.Cells.count > 1 Then
    TgValue = extractData(Target)
 Else
    TgValue = Array(Array(Target.value, Target.Address(0, 0)))  'put the target range in an array (or as a string for a single cell)
    boolOne = True
 End If
 Application.EnableEvents = False                               'avoiding to trigger the change event after UnDo
     Application.Undo
     RangeValues = extractData(Target)                                 'define the RangeValue
     putDataBack TgValue, ActiveSheet                           'put back the changed data
     If boolOne Then Target.Offset(1).Select
 Application.EnableEvents = True

 For r = 0 To UBound(RangeValues)
    If RangeValues(r)(0) <> TgValue(r)(0) Then
        sh.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
          Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.name)
        
    End If
 Next r
 
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

Sub putDataBack(arr, sh As Worksheet)
    Dim i As Long, arrInt, El
    For Each El In arr
        sh.Range(El(1)).value = El(0)
    Next
End Sub

Function extractData(rng As Range) As Variant
    Dim a As Range, arr, count As Long, i As Long
    ReDim arr(rng.Cells.count - 1)
    For Each a In rng.Areas
            For i = 1 To a.Cells.count
                arr(count) = Array(a.Cells(i).value, a.Cells(i).Address(0, 0)): count = count + 1
            Next
    Next
    extractData = arr
End Function

标签： excelvba

解决方案

请使用下一个更新的代码：

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
 Dim sh As Worksheet: Set sh = Sheets("LOG_")
 Dim UN As String: UN = Application.userName
 
 'If Not Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub      'not doing anything if a cell in A:A is changed
 'If Not Intersect(ActiveCell, Range("1:2")) Is Nothing Then Exit Sub  'Not doing anything if a cell is changed in first two rows
  sh.Unprotect "" 'use here your real password
 If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 8) = _
                                     Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name", "Row label", "Colum label")

 Application.ScreenUpdating = False                                     'to optimize the code (make it faster)
 Application.Calculation = xlCalculationManual
 
 If Target.cells.count > 1 Then
    TgValue = extractData(Target)
 Else
    TgValue = Array(Array(Target.value, Target.Address(0, 0)))  'put the target range in an array (or as a string for a single cell)
    boolOne = True
 End If
 Application.EnableEvents = False                                        'avoiding to trigger the change event after UnDo
     Application.Undo
     RangeValues = extractData(Target)                                 'define the RangeValue
     putDataBack TgValue, ActiveSheet                                  'put back the changed data
     If boolOne Then Target.Offset(1).Select
 Application.EnableEvents = True

 Dim columnHeader As String, rowHeader As String
 For r = 0 To UBound(RangeValues)
    If RangeValues(r)(0) <> TgValue(r)(0) Then
        columnHeader = cells(1, Range(RangeValues(r)(1)).Column).value
        rowHeader = Range("A" & Range(RangeValues(r)(1)).row).value
        sh.cells(rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 8).value = _
                Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name, rowHeader, columnHeader)
    End If
 Next r
 
 sh.Protect ""
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

Sub putDataBack(arr, sh As Worksheet)
    Dim i As Long, arrInt, El
    For Each El In arr
        sh.Range(El(1)).value = El(0)
    Next
End Sub
Function extractData(rng As Range) As Variant
    Dim a As Range, arr, count As Long, i As Long
    ReDim arr(rng.cells.count - 1)
    For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
            For i = 1 To a.cells.count
                arr(count) = Array(a.cells(i).value, a.cells(i).Address(0, 0)): count = count + 1
            Next
    Next
    extractData = arr
End Function

请测试代码并发送一些反馈。

如果您希望不允许在 A:A 列或前两个合并行中记录修改，请取消注释以 开头的行If Not Intersect(...。让代码记录刚刚更改的列/行标题对我来说看起来很奇怪。但这当然取决于你。你应该更清楚你需要完成什么...

我建议您保护工作表，解锁所有单元格，然后只锁定 A:A 列和前两行。这样，用户就不能删除应该在记录过程中用作参考的标头。

请取消对 LOG_ 表的保护并删除第一行的标题。

推荐阅读