Код Excel VBA с использованием циклов для копирования и вставки

Question

У меня большой набор дублирующих данных, я хочу иметь возможность скопировать каждое уникальное значение и дважды вставить его в новый рабочий лист, чтобы значения A1 и A2 были одинаковыми для первого значения.Затем для следующего уникального значения я хочу, чтобы A3 и A4 были одинаковыми и так далее до конца столбца.Как мне это сделать?Я предполагаю, что это будет своего рода цикл for или do.

Итак, предположим, что столбец C находится на другом листе, но я хочу, чтобы данные были упрощены следующим образом

Answer 1

Несколько уникальных значений

Тщательно настройте переменные в разделе константы .Первые 7 переменных должны быть самоочевидными.

cBlnTargetFirstRow при значении True позволяет вычислить первую строку в Целевом рабочем листе, например, если вы хотите добавить данные к данным, уже находящимся в этом столбце. *Значение 1008 *

cBlnTargetNewWorksheet, установленное в значение True, позволяет выводить результат в новом рабочем листе, который добавляется в конец.

cIntBuffer - это приращение размера уникального массива, т. Е. КаждогоКогда массив заполнен, это количество добавляется к его размеру.

'*******************************************************************************
' Purpose:    In a column, copies unique values, from each cell a specific
'             number of times, to another column.
'*******************************************************************************
Sub MultiUniqueValues()

  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
  End With

  On Error GoTo UnexpectedErr

  Const cVntSource As Variant = "Sheet1"          ' Source Worksheet Name/Index
  Const cVntTarget As Variant = "Sheet1"          ' Target Worksheet Name/Index
  Const cLngSourceFR As Long = 1                  ' Source First Row
  Const cLngTargetFR As Long = 1                  ' Target First Row
  Const cVntSourceC As Variant = "C"              ' Source Column Letter/Number
  Const cVntTargetC As Variant = "A"              ' Target Column Letter/Number
  Const cIntRepeat As Integer = 2                 ' Unique Values Repeat Count

  Const cBlnTargetFirstRow As Boolean = False     ' Target First Row Calculation
  Const cBlnTargetNewWorksheet As Boolean = False ' Target Worksheet Creation
  Const intBuffer As Long = 10                    ' Unique Array Resize Buffer

  Dim vntSource As Variant      ' Source Array
  Dim vntUni As Variant         ' Unique Array
  Dim vntTarget As Variant      ' Target Array

  Dim lng1 As Long              ' Source Array Counter
  Dim lng2 As Long              ' Unique Array Counter, Repeat Counter
  Dim lng3 As Long              ' Unique Values Count(er), Target Array Counter

  ' Paste column range into one-based 2-dimensional (1B2D) Source Array.
  With ThisWorkbook.Worksheets(cVntSource)
    vntSource = .Range(.Cells(cLngSourceFR, cVntSourceC), _
        .Cells(.Rows.Count, cVntSourceC).End(xlUp))
  End With

  ' Try to write first non-empty row from 1B2D Source to 1B1D Unique Array.
  For lng1 = 1 To UBound(vntSource)
    If Not IsEmpty(vntSource(lng1, 1)) Then
      ReDim vntUni(1 To intBuffer)
      vntUni(1) = vntSource(lng1, 1)
      lng3 = 1
      Exit For
    End If
  Next
  If lng1 = UBound(vntSource) + 1 Then GoTo SourceArrayErr ' No non-empty.

  ' Write the rest of the non-empty rows from 1B2D Source to 1B1D Unique Array.
  For lng1 = lng1 + 1 To UBound(vntSource)
    For lng2 = 1 To lng3
      ' Check if current row of Source Array is empty and check it against
      ' all values in current Unique Array.
      If IsEmpty(vntSource(lng1, 1)) Or _
          vntUni(lng2) = vntSource(lng1, 1) Then Exit For ' Match found.
    Next ' Match not found i.e. "'counter' = 'end' + 1".
      If lng2 = lng3 + 1 Then
        lng3 = lng2 ' (lng3 + 1)
        ' Resize 1B1D Unique Array if full.
        If (lng3 - 1) Mod intBuffer = 0 Then
          ReDim Preserve vntUni(1 To UBound(vntUni) + intBuffer)
        End If
        vntUni(lng3) = vntSource(lng1, 1) ' Write row to Unique Array.
       Else
      End If
  Next
  Erase vntSource

  ' Resize 1B1D Unique Array i.e. truncate last empty rows.
  ReDim Preserve vntUni(1 To lng3)

  ' Copy 1B1D Unique Array to 1B2D Target Array.
  ReDim vntTarget(1 To lng3 * cIntRepeat, 1 To 1)
  lng3 = 0
  For lng1 = 1 To UBound(vntUni)
    For lng2 = 1 To cIntRepeat
      lng3 = lng3 + 1
      vntTarget(lng3, 1) = vntUni(lng1)
    Next
  Next
  Erase vntUni

  ' Note:     To shorten the following code, an Object reference could have
  '           been implemented. Didn't wanna do that.

  ' Paste 1B2D Target Array into Target Range.
  If cBlnTargetNewWorksheet Then  ' Paste into range of new worksheet.
    With ThisWorkbook.Worksheets(cVntTarget)
      .Parent.Sheets.Add After:=.Parent.Sheets(Sheets.Count)
      With .Parent.Worksheets(Sheets.Count) ' It is the ActiveSheet, now.
        If cBlnTargetFirstRow Then    ' Target first row calculation enabled.
          If .Cells(.Rows.Count, cVntTargetC).End(xlUp).Row = 1 And _
              IsEmpty(.Cells(.Cells(.Rows.Count, _
              cVntTargetC).End(xlUp).Row, cVntTargetC)) Then
            .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row, _
                cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
           Else
            .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row + 1, _
                cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
          End If
         Else                         ' Target first row calculation disabled.
          .Cells(cLngTargetFR, cVntTargetC).Resize(UBound(vntTarget)) _
               = vntTarget
        End If
      End With
    End With
   Else                           ' Paste into range of specified worksheet.
    With ThisWorkbook.Worksheets(cVntTarget)
      If cBlnTargetFirstRow Then      ' Target first row calculation enabled.
        If .Cells(.Rows.Count, cVntTargetC).End(xlUp).Row = 1 And _
            IsEmpty(.Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row, _
            cVntTargetC)) Then
          .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row, _
              cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
         Else
          .Cells(.Cells(.Rows.Count, cVntTargetC).End(xlUp).Row + 1, _
              cVntTargetC).Resize(UBound(vntTarget)) = vntTarget
        End If
       Else                           ' Target first row calculation disabled.
        .Cells(cLngTargetFR, cVntTargetC).Resize(UBound(vntTarget)) _
             = vntTarget
      End If
    End With
  End If
  Erase vntTarget

ProcedureExit:
  With Application
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
  End With

Exit Sub

SourceArrayErr:
  MsgBox "No data in Source Array."
  GoTo ProcedureExit

UnexpectedErr:
  MsgBox "An unexpected error occurred. Error: '" & Err.Number & "', " _
      & Err.Description
  GoTo ProcedureExit

End Sub
'*******************************************************************************

Answer 2

Вы можете использовать коллекцию, а затем ввести на другой лист.Столбец 2 листа С содержит исходные данные.

Sub UsingCollection()
    Dim cUnique As Collection
    Dim Rng As Range, r As Long
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant

    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set ws = Sheets("Sheet2")
    Set Rng = ws.Range("C2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
    Set cUnique = New Collection

    On Error Resume Next
    For Each Cell In Rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0

    For Each vNum In cUnique
        r = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Range(Cells(r, 1), Cells(r + 1, 1)).Value = vNum

    Next vNum

End Sub