Нужен способ ввода данных в указанных c ячейках с Excel VBA

Question

Попытка найти для al oop, который считывает номера счетов в столбце «E» в «Информационном листе», начиная с «E2», берет это число и вводит его в первую строку, содержащую пустую белую ячейку на Лист «Подтверждение» («E4») под разделом номера счета. Как только номер помещен туда, «длинное имя» (найденное в таблице в 200-й строке), связанное с номером счета в ячейке «E4», появляется в первой пустой белой ячейке («B4») под разделом имени учетной записи , Затем l oop продолжается и читает следующую ячейку ('E3') на «Листе ввода», и, если этот номер счета принадлежит тому же имени, поместите этот номер в следующую белую ячейку ('G4') на лист «Доказательство». Если номер учетной записи не связан с именем учетной записи в ячейке «B4», поместите его в следующую строку, содержащую пустую белую ячейку «E12», и назначьте соответствующее имя для этого номера в ячейке под именем учетной записи в ячейке «B12» и продолжайте вниз по списку в столбце «E» на информационном листе и повторяйте процесс до тех пор, пока не будут заполнены все номера счетов на первом листе, и все соответствующие номера счетов не будут находиться в строке с соответствующим «длинным именем» для этих номеров счетов. .

Как разместить все учетные записи, связанные с именем учетной записи, в одной строке в указанных c белых ячейках, не размещая их дважды в одной строке?

Это код, который у меня есть:

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

Взгляните на фрагменты для справки.

Лист ввода информации

Лист подтверждения

Код в настоящее время делает это:

Посмотрите, как в примерах практики, которые, как предполагается, имитируют c На реальных листах имя появляется в нескольких строках с соответствующими номерами счетов, когда они должны появляться в одной строке под одним и тем же именем со всеми номерами счетов в одной строке.

Answer 1

Итак, это код, который я сейчас использую. Я встроил код в событие изменения, когда ячейка в диапазоне изменяется. Но мне было интересно узнать, существует ли способ, с помощью которого код может гарантировать, что, если номер счета уже находится в ячейке, он не должен снова публиковать тот же номер в следующей ячейке в той же строке. Это означает, что каждый раз, когда происходит изменение в диапазоне, макрос запускается заново и размещает числа повторно. Я предполагаю, что мне нужно сделать сброс где-то в коде, но я не знаю, как и где.

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

Answer 2

Попробуйте это. Я не использовал find метод, потому что вы, вероятно, выполните много поисков по одному и тому же набору данных. Поэтому я загрузил его в массив, который будет искать вместо объекта диапазона (это быстрее ).

Нужно иметь в виду одну вещь - перед ее запуском необходимо УДАЛИТЬ все номера счетов в пробном листе.

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