VBA 循环 - 将单元格复制并粘贴到下一列,直到单元格 x 等于单元格 y
VBA Loop - copy and paste cells into next column until cell x equals cell y
我需要一些循环帮助。我有一段时间没有使用 VBA 并开始重新学习。我记得这个社区在过去帮助了我很多,所以任何帮助都将不胜感激。
挑战
我想将单元格 H12 复制到下一个以 i12 开头的空列,然后是 J12,依此类推。所以我想继续循环,直到粘贴数组的数量等于单元格 D12 中的数量。因此,如果单元格 D12 = 20,我想继续这个循环复制 H12,直到我到达 AB12。
完成后,我想转到下一行 H13 并执行相同的操作。在这种情况下 D13 = 15 所以我们和上面一样复制 H13 直到我们到达 R13.
非常感谢任何帮助。我已经尝试了一些循环来解决其他没有解决的问题。
假设您的 selected 单元格是 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
如果您 select 具有相同前提条件的下一行,它也可以工作
重复的单元格值
用法(OP)
- 将所有代码复制到标准模块中,例如
Module1
.
- 调整常量部分中的值。
如何测试(任何人)
- 添加一个新工作簿(或只打开
Excel
)。在VBE
中添加一个新的标准模块并将代码复制到其中。在 Excel
中,在工作表 Sheet1
中,在从单元格 D12
开始的列 D
中,添加一些正整数(整数),并在列 [=18] 中的相应单元格中=] 添加要复制的值。 运行 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 '" _
& sfCell.Resize(ws.Rows.Count - sfCell.Row + 1).Address(0, 0) _
& "'.", 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
我需要一些循环帮助。我有一段时间没有使用 VBA 并开始重新学习。我记得这个社区在过去帮助了我很多,所以任何帮助都将不胜感激。
挑战
我想将单元格 H12 复制到下一个以 i12 开头的空列,然后是 J12,依此类推。所以我想继续循环,直到粘贴数组的数量等于单元格 D12 中的数量。因此,如果单元格 D12 = 20,我想继续这个循环复制 H12,直到我到达 AB12。
完成后,我想转到下一行 H13 并执行相同的操作。在这种情况下 D13 = 15 所以我们和上面一样复制 H13 直到我们到达 R13.
非常感谢任何帮助。我已经尝试了一些循环来解决其他没有解决的问题。
假设您的 selected 单元格是 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
如果您 select 具有相同前提条件的下一行,它也可以工作
重复的单元格值
用法(OP)
- 将所有代码复制到标准模块中,例如
Module1
. - 调整常量部分中的值。
如何测试(任何人)
- 添加一个新工作簿(或只打开
Excel
)。在VBE
中添加一个新的标准模块并将代码复制到其中。在Excel
中,在工作表Sheet1
中,在从单元格D12
开始的列D
中,添加一些正整数(整数),并在列 [=18] 中的相应单元格中=] 添加要复制的值。 运行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 '" _
& sfCell.Resize(ws.Rows.Count - sfCell.Row + 1).Address(0, 0) _
& "'.", 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