需要一种使用 Excel VBA 在特定单元格中输入数据的方法

Question

试图解决从“E2”开始读取“信息表”上“E”列中的帐号并获取该数字并将其输入到“证明”上包含空白单元格的第一行的循环" 帐号部分下的工作表 ('E4')。将号码放在那里后，与单元格“E4”中的帐号关联的“长名称”（在第 200 行的表格中找到）出现在帐户名称部分下的第一个空白单元格（“B4”）中.然后，循环继续并读取“输入表”上的下一个单元格（'E3'），如果该帐号属于同一名称，则将该号码放在“证明”上的下一个白色单元格（'G4'）中“ 床单。如果帐号与单元格“B4”中的帐户名没有关联，请将其放在包含空白单元格“E12”的下一行中，并在单元格“B12”中的帐户名下的单元格中为该号码分配适当的名称，然后继续在信息表上的“E”列中的列表并重复该过程，直到第一张表上的所有帐号都完成并且所有适当的帐号都在具有这些帐号的适当“长名称”的行上.

如何将与帐户名称关联的所有帐户放在特定白色单元格的同一行中，而不在同一行中发布两次？

这是我的代码：

Sub loopything()


Dim infoSheet As Worksheet, proofSheet As Worksheet, refRange As         Range, lastRow As Long, r As Long
Dim acct As String, foundAcct As Range, nextRow As Long
Set infoSheet = ThisWorkbook.Sheets("Info Sheet")
Set proofSheet = ThisWorkbook.Sheets("Proof")

With proofSheet
nextRow = 4 ' waiting to adjust to normal table format
End With

With proofSheet

Set refRange = .Range("A200:L79000")

End with 

With InfoSheet

lastRow = 30 ' .cells(.rows.count, "E").end(xlup).row

For r = 2 To lastRow

acct = .Cells(r, "E")
Set foundAcct = refRange.Find(what:=acct)
longname = foundAcct.Offset(0, 1)


proofSheet.Cells(nextRow, "E") = acct
proofSheet.Cells(nextRow, "B") = longname
nextRow = nextRow + 8   ' would be nicer to just add one row (see  first note)

Next r

End With

End Sub

查看 sn-ps 以供参考。

信息输入表

校样表

代码目前正在这样做：

看看在应该模仿真实表格的练习示例中，名称如何出现在多行上，并带有各自的帐号，而它们应该以相同的名称出现在同一行上，并且所有帐号都在一个上排。

Answer 1

试试这个。我没有使用find 方法，因为您可能会在同一个数据集上进行多次搜索。所以我将它加载到一个数组中，而不是一个范围对象（它是faster）。

要记住一件事 - 在运行它之前，您需要删除 Proof sheet 中的所有帐号。

Sub loopything()

  Dim wsInfoSheet As Worksheet
  Dim wsProofSheet As Worksheet
  Dim lngLastRow As Long
  Dim r As Long
  Dim sAcct As String
  Dim lngNextRow As Long
  Dim sLongName As String

  Dim arrRef() As Variant
  Dim arrNames() As String
  Dim i As Long
  Dim lngRowInNames As Long
  Dim lngFoundName As Long

  Set wsInfoSheet = ThisWorkbook.Sheets("Info Sheet")
  Set wsProofSheet = ThisWorkbook.Sheets("Proof")

  ' Will be used in the Proof sheet
  lngNextRow = 4 ' waiting to adjust to normal table format

  arrRef = wsProofSheet.Range("A200:L79000").Value
  ReDim arrNames(1 To UBound(arrRef, 1) + 1, 1 To 2)

  With wsInfoSheet

    lngLastRow = 30 ' .cells(.rows.count, "E").end(xlup).row

    lngRowInNames = 1
    For r = 2 To lngLastRow
      sAcct = .Cells(r, "E")
      'lookup for sAcct in arrRef
      For i = 1 To UBound(arrRef, 1)
        If arrRef(i, 1) = sAcct Then
          sLongName = arrRef(i, 2) '(row i, column 2 from arrRef)
          arrNames(lngRowInNames, 1) = sLongName
          arrNames(lngRowInNames, 2) = lngNextRow
          lngRowInNames = lngRowInNames + 1
          Exit For
        End If
      Next
      'lookup for sLongName in arrNames
      For i = 1 To UBound(arrNames, 1)
        If arrNames(i, 1) = sLongName Then
          lngFoundName = i
          Exit For
        End If
      Next

      'if the name is new
      If arrNames(lngFoundName + 1, 1) = "" Then
        wsProofSheet.Cells(lngNextRow, "E") = sAcct
        wsProofSheet.Cells(lngNextRow, "B") = sLongName
        lngNextRow = lngNextRow + 8   ' would be nicer to just add one row (see  first note)
      'if the name already exists
      Else
        wsProofSheet.Cells(arrNames(lngFoundName, 2), wsProofSheet.Cells(arrNames(lngFoundName, 2), wsProofSheet.Columns.Count).End(xlToLeft).Column + 3) = sAcct
      End If

    Next 'r

  End With

End Sub

Answer 2

所以，这是我目前正在使用的代码。当范围内的单元格发生更改时，我将代码嵌入到更改事件中。但是，我很想知道代码是否有办法确保如果帐号已经在一个单元格中，它不应该在同一行的下一个单元格中再次发布相同的号码。这意味着，每次范围发生变化时，宏都会重新运行并重复放置数字。我假设我需要在代码中的某处进行重置，但我不知道如何或在哪里。

Sub worksheet_Change(ByVal target As Range)

If Not Application.Intersect(target, Range("D2:D30")) Is Nothing Then
Application.EnableEvents = False
Dim wsInfoSheet As Worksheet
Dim wsProofSheet As Worksheet
Dim lngLastRow As Long
Dim r As Long
Dim sAcct As String
Dim lngNextRow As Long
Dim sLongName As String

Dim arrRef() As Variant
Dim arrNames() As String
Dim i As Long
Dim lngRowInNames As Long
Dim lngFoundName As Long

Set wsInfoSheet = ThisWorkbook.Sheets("Info Input")
Set wsProofSheet = ThisWorkbook.Sheets("Proof")

'Will be used in the Proof sheet
lngNextRow = 4 ' waiting to adjust to normal table format

arrRef = wsProofSheet.Range("A199:L79000").Value
ReDim arrNames(1 To UBound(arrRef, 1) + 1, 1 To 2)

With wsInfoSheet

lngLastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

lngRowInNames = 1
For r = 2 To lngLastRow
  sAcct = .Cells(r, "E")
  'lookup for sAcct in arrRef
  For i = 1 To UBound(arrRef, 1)
    If arrRef(i, 1) = sAcct Then
      sLongName = arrRef(i, 12) '(row i, column 2 from arrRef)
      arrNames(lngRowInNames, 1) = sLongName
      arrNames(lngRowInNames, 2) = lngNextRow
      lngRowInNames = lngRowInNames + 1
      Exit For
    End If
  Next
  'lookup for sLongName in arrNames
  For i = 1 To UBound(arrNames, 1)
    If arrNames(i, 1) = sLongName Then
      lngFoundName = i
      Exit For
    End If
  Next

  'if the name is new
  If arrNames(lngFoundName + 1, 1) = "" Then
    wsProofSheet.Cells(lngNextRow, "E") = sAcct
    wsProofSheet.Cells(lngNextRow, "B") = sLongName
    lngNextRow = lngNextRow + 8   ' would be nicer to just add one row (see  first note)
  'if the name already exists
  Else
    wsProofSheet.Cells(arrNames(lngFoundName, 2), wsProofSheet.Cells(arrNames(lngFoundName, 2), wsProofSheet.Columns.Count).End(xlToLeft).Column + 3) = sAcct
  End If

Next 'r

End With
Application.EnableEvents = True
End If

Dim iCell As Range
If Not Application.Intersect(target, Range("A2:A30")) Is Nothing Then
Application.EnableEvents = False
For Each iCell In Range("A2:A30")
    If iCell.Address = target.Address Then
        Range("C" & iCell.Row).ClearContents
        Range("D" & iCell.Row).ClearContents
        Range("I" & iCell.Row).ClearContents
    End If
Next iCell

End If
Application.EnableEvents = True
End Sub