Блог

Здравствуйте, у меня есть столбец клиентов и столбец доступных им вознаграждений. Мне нужно просмотреть награды и добавить отдельную строку, содержащую номер клиента, на новый лист. Итак, для примера, у первого клиента было бы 30 855 строк на листе с номером клиента 3025480 в столбце A.

У меня нет большого опыта работы с vba, и проблема настолько специфична, что у меня возникают проблемы с поиском помощи. Итак, я надеюсь, что вы, ребята, сможете помочь.

Спасибо

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

 Public Sub MakeRewards()
    
    Dim rCell As Range
    Dim i As Long
    Dim lCnt As Long
    
    For Each rCell In Sheet1.Range("A2:A5").Cells 'loop through all the customers
        For i = 1 To rCell.Offset(0, 1).Value 'create a loop to go from 1 to whatever number is in the next cell
            lCnt = lCnt   1 'Keep track of what row you're on in Sheet2
            Sheet2.Cells(lCnt, 1) = rCell.Value 'Write the customer number to sheet2
        Next i
    Next rCell
    
End Sub
  

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

Вот лучший способ. Он считывает диапазон Excel в массив (быстрее) и записывает номер клиента за один раз (намного быстрее). Это запустилось в мгновение ока.

 Public Sub MakeRewards2()
    
    Dim vaValues As Variant
    Dim i As Long
    Dim lCnt As Long
    
    vaValues = Sheet1.Range("A2:B5").Value
    lCnt = 1
    
    For i = LBound(vaValues, 1) To UBound(vaValues, 1)
        Sheet2.Cells(lCnt, 1).Resize(vaValues(i, 2)).Value = vaValues(i, 1)
        lCnt = lCnt   vaValues(i, 2)
    Next i
    
End Sub
  

Создание строк

• Скопируйте код в стандартный модуль, например Module1 .
• Отрегулируйте значения в разделе constants.
• ThisWorkbook означает рабочую книгу, содержащую этот код.

Код

 Option Explicit

Sub createReward()
    
    ' Source
    Const srcName As String = "Sheet1"
    Const FirstRow As Long = 2
    Const LastRowColumn As Variant = "A"              ' e.g. 1 or "A"
    Dim srcCols As Variant: srcCols = Array("A", "B") ' e.g. 1 or "A"
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtFirstCell As String = "A2"
    ' Other
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define worksheet.
    Dim src As Worksheet: Set src = wb.Worksheets(srcName)
    
    ' Define Last Row Column Range.
    Dim rng As Range
    Set rng = src.Columns(LastRowColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Sub
    If rng.Row < FirstRow Then Exit Sub
    Set rng = src.Range(src.Cells(FirstRow, LastRowColumn), rng)
    
   ' Write values from Source ranges to Source arrays.
    Dim ubc As Long: ubc = UBound(srcCols)
    Dim Source As Variant: ReDim Source(0 To ubc)
    Dim Target As Variant: Dim j As Long
    If rng.Rows.Count > 1 Then
        For j = 0 To ubc
            Source(j) = rng.Offset(, src.Columns(srcCols(j)).Column _
                                   - src.Columns(LastRowColumn).Column).Value
        Next j
    Else
        ' Borrowed Target to create 1 by 1 array.
        ReDim Target(1 To 1, 1 To 1)
        For j = 0 To ubc
            Source(j) = Target
            Source(j)(1, 1) = rng.Offset(, src.Columns(srcCols(j)).Column _
                            - src.Columns(LastRowColumn).Column).Value
        Next j
    End If
    
    ' Write values from Source arrays to Target array.
    Dim ubs As Long: ubs = UBound(Source(0))
    Dim ubt As Long: ubt = Application.Sum(Source(1))
    ReDim Target(1 To ubt, 1 To 1)
    Dim i As Long, k As Long, Curr As Variant
    For j = 1 To ubs
        Curr = Source(0)(j, 1)
        For i = 1 To Source(1)(j, 1)
            k = k   1
            Target(k, 1) = Curr
        Next i
    Next j
    
    ' Write values from Target array to Target range.
    Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
    tgt.Range(tgtFirstCell).Resize(tgt.Rows.Count _
                                 - tgt.Range(tgtFirstCell).Row).ClearContents
    tgt.Range(tgtFirstCell).Resize(ubt).Value = Target
    
    ' Inform user.
    MsgBox "Reward template created.", vbInformation, "Success"

End Sub