Блог

Мне нужна помощь в зацикливании. Я уже некоторое время не использую VBA и снова начинаю учиться. Я помню, что это сообщество очень помогало мне в прошлом, поэтому любая помощь будет оценена по достоинству.

Задача

Я хочу скопировать ячейку H12 в следующий пустой столбец, начиная с i12, затем J12 и так далее. Поэтому я хочу продолжить цикл до тех пор, пока количество вставленных массивов не сравняется с числом в ячейке D12. Поэтому, если ячейка D12 = 20, я хочу продолжить этот цикл копирования H12, пока не доберусь до AB12.

Затем, как только это будет завершено, я хочу перейти к следующей строке H13 и сделать то же самое. В этом случае D13 = 15, поэтому мы делаем то же самое, что и выше, копируя H13, пока не доберемся до R13.

Любая помощь действительно ценится. Я попробовал несколько циклов для других вещей, которые не сработали.

В предположении, что выбранная вами ячейка имеет значение H12, а ячейки справа от нее пусты, а D12 заполнен положительным числовым значением, должен работать следующий код:

 Sub CopyToRange()

Dim ThisCol As Integer, ThisRow As Long, CurS As Worksheet, CurRg As Range, InfCol As Integer

Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 4 'column 'D'
Set CurRg = Range(CurS.Cells(ThisRow, ThisCol   1), CurS.Cells(ThisRow, ThisCol   CurS.Cells(ThisRow, InfCol).Value))
ActiveCell.Copy
CurRg.PasteSpecial (xlPasteAll)

End Sub
 

Если вы выберете следующую строку с теми же предварительными условиями, она также будет работать

Повторяющиеся Значения Ячеек

Использование (OP)

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

Как проверить (кого угодно)

• Добавьте новую книгу (или просто откройте Excel ). В VBE добавьте новый стандартный модуль и скопируйте в него код. На Excel листе Sheet1 , в столбце D , начиная с ячейки D12 , добавьте несколько целых положительных чисел (целых чисел), а в соответствующие ячейки столбца H добавьте значения, которые будут дублироваться. Выполните DuplicateCellValues процедуру.

Код

 Option Explicit

Sub DuplicateCellValues()
    ' Needs the 'RefColumn' function.
    Const ProcTitle As String = "Duplicate Cell Values"
    
    Const wsName As String = "Sheet1"
    Const sFirst As String = "D12" ' Column 'D': number of duplicates.
    Const dfCol As String = "H" ' Column 'H': value to duplicate.
    
    ' Create a reference to the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Create a reference to the worksheet ('ws').
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    ' Create a reference to the Source First Cell ('sfCell').
    Dim sfCell As Range: Set sfCell = ws.Range(sFirst)
    ' Create a reference to the Source Column Range ('scrg').
    Dim scrg As Range: Set scrg = RefColumn(sfCell)
    ' Check if no data in the Source Column Range was found.
    If scrg Is Nothing Then
    ' Inform and exit.
        MsgBox "There is no data in the one-column range '" _
            amp; sfCell.Resize(ws.Rows.Count - sfCell.Row   1).Address(0, 0) _
            amp; "'.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range ' Current Source Cell
    Dim drrg As Range ' Destination Row Range
    Dim dfCell As Range ' Destination First Cell
    
    ' Loop through the cells ('sCell') of Source Column Range.
    For Each sCell In scrg.Cells
        ' Create a reference to the current Destination First Cell.
        Set dfCell = sCell.EntireRow.Columns(dfCol)
        ' Attempt to create a reference to the Destination Row Range.
        ' It may fail if there is no whole number in the current Source Cell,
        ' or if the number is too small, or if it is too big,... etc.
        On Error Resume Next
        Set drrg = dfCell.Offset(0, 1).Resize(1, sCell.Value)
        On Error GoTo 0
        ' If the reference was created...
        If Not drrg Is Nothing Then ' *** Destination Row Range referenced.
            ' Write the value from the current First Destination Cell
            ' to the cells of the Destination Row Range.
            drrg.Value = dfCell.Value
            ' Dereference the Destination Row Range for the 'On Error Resume Next'
            ' to work 'correctly'.
            Set drrg = Nothing
        'Else ' *** Destination Row Range NOT referenced.
        End If
    Next sCell
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Cells duplicated.", vbInformation, ProcTitle
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row   1)
    End With

End Function
 

Попробуй это:

     Option Explicit
    Sub duplicate()
        Dim arr, LastRow As Long
        With Sheet8
            LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
            arr = .Range(.Cells(12, 4), .Cells(LastRow, 100)).Value2
        End With
        
        Dim j As Long, i As Long, ii As Long: ii = 1
        For j = 1 To UBound(arr)
            For i = 6 To 5   (arr(j, 1) * ii)
                arr(j, i) = arr(j, 5)
            Next i
        Next j
        
        With Sheet8
            .Range(.Cells(12, 4), .Cells(LastRow, 100)) = arr 'dump updated array to invoice sheet
        End With
    End Sub