Fatal编程技术网
  • excel/
  • Excel VBA复制特定单元格并粘贴到相邻列中

Excel VBA复制特定单元格并粘贴到相邻列中

excel vba

Excel VBA复制特定单元格并粘贴到相邻列中,excel,vba,Excel,Vba,我试图创建VBA代码，将数据从特定单元格复制并粘贴到一系列单元格中，直到其为空。我没有丰富的VBA经验，因此我正在努力创建这样的代码 我想创建一个代码来循环整个数据集，例如B2单元需要从A5复制到A9。然后，B12将从A15复制到A19 一直到列表完成为止[复制数据] 任何帮助都将不胜感激。我的代码不好，可能有点慢。我还没有测试过 写在手机上，很抱歉格式错误 Option Explicit Sub FillDown() ' I assume Sheet1, change it to what

我试图创建VBA代码，将数据从特定单元格复制并粘贴到一系列单元格中，直到其为空。我没有丰富的VBA经验，因此我正在努力创建这样的代码

我想创建一个代码来循环整个数据集，例如B2单元需要从A5复制到A9。然后，B12将从A15复制到A19

一直到列表完成为止[复制数据]

任何帮助都将不胜感激。

我的代码不好，可能有点慢。我还没有测试过

写在手机上，很抱歉格式错误

Option Explicit

Sub FillDown()

' I assume Sheet1, change it to whatever your sheet's name is
With Thisworkbook.worksheets("Sheet1")

application.screenupdating = false
application.calculation = xlcalculationmanual

Dim lastRow as long
lastRow = .cells(.rows.count, "B").end(xlup).row

Dim rowIndex as long

For rowIndex = 1 to lastRow

If .cells(rowIndex, "B").value2 = "Day Date" then

.cells(rowIndex, "B").offset(3, -1).resize(5,1).value2 = .cells(rowIndex-2, "B").value2

rowIndex = rowIndex + 5
End if

Next rowIndex

End with

application.screenupdating = true
application.calculation = xlcalculationautomatic

End sub
我的代码不好，可能有点慢。我还没有测试过

写在手机上，很抱歉格式错误

Option Explicit

Sub FillDown()

' I assume Sheet1, change it to whatever your sheet's name is
With Thisworkbook.worksheets("Sheet1")

application.screenupdating = false
application.calculation = xlcalculationmanual

Dim lastRow as long
lastRow = .cells(.rows.count, "B").end(xlup).row

Dim rowIndex as long

For rowIndex = 1 to lastRow

If .cells(rowIndex, "B").value2 = "Day Date" then

.cells(rowIndex, "B").offset(3, -1).resize(5,1).value2 = .cells(rowIndex-2, "B").value2

rowIndex = rowIndex + 5
End if

Next rowIndex

End with

application.screenupdating = true
application.calculation = xlcalculationautomatic

End sub
略为不同的方法。是动态的，您可以增加或减少A列中的范围（黄色部分）

VBA代码：

Sub CopyPaste()

Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")     'Sheet name
Dim lrow As Long
Dim cl As Variant
Dim myRange As Range
Dim currentRow As Long
Dim currentRowValue As String
Dim currRow As Long

lrow = ws.Cells(Rows.Count, 2).End(xlUp).Row     'Find last row in Sheet1
Set myRange = ws.Range(ws.Cells(1, 2), ws.Cells(lrow, 2)) 'Range you want to loop through in Column B, from row 1 to last row

For Each cl In myRange
    Debug.Print cl
    If cl.Value <> "" And cl.Value <> "Day Date" And Not IsDate(cl.Value) Then 'Ignore empty cells, Cells with the word "Day Date" or if the cells contain a date
        For currentRow = cl.Row + 2 To cl.Row + 10
            currentRowValue = Cells(currentRow, 2).Value
            If IsEmpty(currentRowValue) Or currentRowValue = "" Then 'Checks for empty rows in the area below
                currRow = Cells(currentRow, 2).Row
                Exit For
            End If
        Next
        Range(Cells(cl.Row, 1).Offset(3, 0), Cells(currRow - 1, 1)) = Cells(cl.Row, 2) 'Set current value in Column B to the adjacent range (Column A). Offset(3, 0) - this part sets the first cell in the range. Increase "+7" to make range larger
    End If
Next cl                                          'Next value to loop

End Sub

子复制粘贴（）
将ws设置为工作表
设置ws=ActiveWorkbook.Worksheets（“Sheet1”）的工作表名称
暗淡的光线和长的一样
Dim cl作为变体
将myRange变暗为Range
与当前行一样长
将currentRowValue设置为字符串
暗咖喱和长咖喱一样
lrow=ws.Cells（Rows.Count，2）。End（xlUp）。Row“查找表1中的最后一行”
设置myRange=ws.Range（ws.Cells（1，2），ws.Cells（lrow，2））'要在B列中循环的范围，从第1行到最后一行
对于myRange中的每个cl
调试。打印cl
如果cl.Value“”和cl.Value“Day Date”而不是IsDate（cl.Value），则“忽略空单元格、带有单词“Day Date”的单元格，或者如果单元格包含日期
对于当前行=第1行+2至第1行+10
currentRowValue=单元格（currentRow，2）.Value
如果IsEmpty（currentRowValue）或currentRowValue=“”，则“检查下面区域中的空行”
currRow=单元格（currentRow，2）。行
退出
如果结束
下一个
范围（单元格（cl.Row，1）。偏移量（3，0），单元格（currRow-1，1））=单元格（cl.Row，2）“将B列中的当前值设置为相邻范围（A列）。偏移量（3，0）-此部分设置范围中的第一个单元格。增加“+7”使射程变大
如果结束
Next cl'循环的下一个值
端接头
结果：

Sub CopyPaste()

Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")     'Sheet name
Dim lrow As Long
Dim cl As Variant
Dim myRange As Range
Dim currentRow As Long
Dim currentRowValue As String
Dim currRow As Long

lrow = ws.Cells(Rows.Count, 2).End(xlUp).Row     'Find last row in Sheet1
Set myRange = ws.Range(ws.Cells(1, 2), ws.Cells(lrow, 2)) 'Range you want to loop through in Column B, from row 1 to last row

For Each cl In myRange
    Debug.Print cl
    If cl.Value <> "" And cl.Value <> "Day Date" And Not IsDate(cl.Value) Then 'Ignore empty cells, Cells with the word "Day Date" or if the cells contain a date
        For currentRow = cl.Row + 2 To cl.Row + 10
            currentRowValue = Cells(currentRow, 2).Value
            If IsEmpty(currentRowValue) Or currentRowValue = "" Then 'Checks for empty rows in the area below
                currRow = Cells(currentRow, 2).Row
                Exit For
            End If
        Next
        Range(Cells(cl.Row, 1).Offset(3, 0), Cells(currRow - 1, 1)) = Cells(cl.Row, 2) 'Set current value in Column B to the adjacent range (Column A). Offset(3, 0) - this part sets the first cell in the range. Increase "+7" to make range larger
    End If
Next cl                                          'Next value to loop

End Sub

编辑： 复制到另一张纸上

Sub copyNonBlankData()
Dim erow As Long, lastrow As Long, i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Sheet name
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets("Sheet2") 'Sheet name

lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
erow = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

For i = 4 To lastrow
    If ws.Cells(i, 1) <> "" Then
        ws.Range(ws.Cells(i, 1), ws.Cells(i, 1)).Copy 'Copy Serial number
        ws2.Range(ws2.Cells(erow, 1), ws2.Cells(erow, 1)).PasteSpecial xlPasteAll 'Paste serial
        ws.Range(ws.Cells(i, 2), ws.Cells(i, 2)).Copy 'Copy date
        ws2.Range(ws2.Cells(erow, 3), ws2.Cells(erow, 3)).PasteSpecial xlPasteAll 'Paste serial
        ws.Range(ws.Cells(i, 3), ws.Cells(i, 4)).Copy 'Copy values
        ws2.Range(ws2.Cells(erow, 5), ws2.Cells(erow, 6)).PasteSpecial xlPasteAll 'Paste values
        ws2.Range(ws2.Cells(erow, 4), ws2.Cells(erow, 4)).Interior.Color = RGB(255, 242, 204) 'Fill Colour in 3rd column
        ws2.Range(ws2.Cells(erow, 2), ws2.Cells(erow, 2)).Borders(xlEdgeBottom).LineStyle = xlContinuous 'Add borders to 2nd column
        ws2.Range(ws2.Cells(erow, 4), ws2.Cells(erow, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous 'Add borders to 4th column
        erow = erow + 1
    End If
Next i
Application.CutCopyMode = False
End Sub

子副本非空白数据（）
昏暗的房间一样长，最后一排一样长，我一样长
将ws设置为工作表
设置ws=ActiveWorkbook.Worksheets（“Sheet1”）的工作表名称
将ws2设置为工作表
设置ws2=ActiveWorkbook.Worksheets（“Sheet2”）的工作表名称
lastrow=ws.Cells（Rows.Count，1）.End（xlUp）.Row
erow=ws2.Cells（Rows.Count，1）.End（xlUp）.Offset（1，0）.Row
对于i=4到最后一行
如果ws.Cells（i，1）“，则
ws.Range（ws.Cells（i，1），ws.Cells（i，1））.Copy“复制序列号”
ws2.Range（ws2.Cells（erow，1），ws2.Cells（erow，1））.PasteSpecial xlPasteAll“粘贴序列”
ws.Range（ws.Cells（i，2），ws.Cells（i，2））.Copy“复制日期”
ws2.Range（ws2.Cells（erow，3），ws2.Cells（erow，3））.PasteSpecial xlPasteAll“粘贴序列”
ws.Range（ws.Cells（i，3），ws.Cells（i，4））.Copy“复制值”
ws2.Range（ws2.Cells（erow，5），ws2.Cells（erow，6））.PasteSpecial xlPasteAll的粘贴值
ws2.Range（ws2.Cells（erow，4），ws2.Cells（erow，4））.Interior.Color=RGB（255，242，204）'第三列中的填充颜色
ws2.Range（ws2.Cells（erow，2），ws2.Cells（erow，2））.Borders（xlEdgeBottom）。LineStyle=xlContinuous“将边框添加到第二列”
ws2.Range（ws2.Cells（erow，4），ws2.Cells（erow，4））.Borders（xlEdgeBottom）。LineStyle=xlContinuous“将边框添加到第四列”
erow=erow+1
如果结束
接下来我
Application.CutCopyMode=False
端接头
更高效的代码

子副本非空白数据（）
昏暗的房间一样长，最后一排一样长，我一样长
将ws设置为工作表
设置ws=ActiveWorkbook.Worksheets（“Sheet1”）“复制自-工作表名称”
将ws2设置为工作表
设置ws2=ActiveWorkbook.Worksheets（“Sheet2”）“粘贴到-工作表名称
Application.ScreenUpdating=False
Application.Calculation=xlCalculationManual
Application.DisplayAlerts=False
lastrow=ws.Cells（Rows.Count，1）.End（xlUp）.Row
erow=ws2.Cells（Rows.Count，1）.End（xlUp）.Offset（1，0）.Row
对于i=4到最后一行
如果ws.Cells（i，1）“，则
使用ws.Range（ws.Cells（i，1），ws.Cells（i，1））
范围（ws2.Cells（erow，1），ws2.Cells（erow，1））.Value=.Value
以
使用ws.Range（ws.Cells（i，2），ws.Cells（i，2））
范围（ws2.Cells（erow，3），ws2.Cells（erow，3））.Value=.Value
以
使用ws.Range（ws.Cells（i，3），ws.Cells（i，4））
范围（ws2.Cells（erow，5），ws2.Cells（erow，6））.Value=.Value
ws2.Range（ws2.Cells（erow，3），ws2.Cells（erow，7））.Interior.Color=RGB（255，242，204）'第三列中的填充颜色
ws2.Range（ws2.Cells（erow，1），ws2.Cells（erow，7））.Borders.LineStyle=xlContinuous“将边框添加到第二列”
以
erow=erow+1
如果结束
接下来我
Application.CutCopyMode=False
Application.ScreenUpdating=True
Application.Calculation=xlCalculationAutomatic
Application.DisplayAlerts=True
端接头
一种稍微不同的方法。是动态的，您可以增加或减少A列中的范围（黄色部分）

VBA代码：

Sub CopyPaste()

Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")     'Sheet name
Dim lrow As Long
Dim cl As Variant
Dim myRange As Range
Dim currentRow As Long
Dim currentRowValue As String
Dim currRow As Long

lrow = ws.Cells(Rows.Count, 2).End(xlUp).Row     'Find last row in Sheet1
Set myRange = ws.Range(ws.Cells(1, 2), ws.Cells(lrow, 2)) 'Range you want to loop through in Column B, from row 1 to last row

For Each cl In myRange
    Debug.Print cl
    If cl.Value <> "" And cl.Value <> "Day Date" And Not IsDate(cl.Value) Then 'Ignore empty cells, Cells with the word "Day Date" or if the cells contain a date
        For currentRow = cl.Row + 2 To cl.Row + 10
            currentRowValue = Cells(currentRow, 2).Value
            If IsEmpty(currentRowValue) Or currentRowValue = "" Then 'Checks for empty rows in the area below
                currRow = Cells(currentRow, 2).Row
                Exit For
            End If
        Next
        Range(Cells(cl.Row, 1).Offset(3, 0), Cells(currRow - 1, 1)) = Cells(cl.Row, 2) 'Set current value in Column B to the adjacent range (Column A). Offset(3, 0) - this part sets the first cell in the range. Increase "+7" to make range larger
    End If
Next cl                                          'Next value to loop

End Sub

子复制粘贴（）
将ws设置为工作表
设置ws=ActiveWorkbook.Worksheets（“Sheet1”）的工作表名称
暗淡的光线和长的一样
Dim cl作为变体
将myRange变暗为Range
与当前行一样长
将currentRowValue设置为字符串
暗咖喱和长咖喱一样
lrow=ws.Cells（Rows.Count，2）。End（xlUp）。Row“查找表1中的最后一行”
设置myRange=ws.Range（ws.Cells（1，2），ws.Cells（lrow，2））'要在B列中循环的范围，从第1行到最后一行
对于myRange中的每个cl
调试。打印cl
如果cl.Value“”和cl.Value“Day Date”而不是IsDate（cl.Value），则“忽略空单元格、带有单词“Day Date”的单元格，或者如果单元格包含日期
对于currentRow=cl.行+2至cl.行+