循环遍历范围并复制到范围

时间：2015-07-27 15:53:33

标签： vba loops range

我很难将行从循环复制到循环。目标循环是所有空白单元格。我已经被困在这3天了，我感觉非常无益。我错过了什么？ 

Sub Testloop()
Dim a As Range, b As Range, d As Range

Sheets("SAP Output DATA").Select
Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)).Select
Selection.SpecialCells(xlCellTypeBlanks).Offset(0, 4).Select
Set d = Selection

Sheets("Input DATA").Select
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set a = Selection

For Each b In a.Rows
b.Copy
    For Each row In d.Rows
        b.PasteSpecial
    Next row
Next b

End Sub

它复制数据，但它复制的数据都是第2行的原始数据，下一个空白单元格不包含输入数据表中的下一行数据。如何遍历行并将其粘贴到空白单元格中？

见图片：

1。     http://i.stack.imgur.com/Jd95G.png

2。     http://i.stack.imgur.com/444RO.png

经过漫长的一天，我仍然无法解决它。这就像我认为生病得到它一样接近。 

Sub Testshttestonemoretime()
    Dim a As Range, b As Range, d As Range, f As Range
    Dim i As Long, r As Range, coltoSearch As String
    Dim sht As Worksheet

    Set sht = ThisWorkbook.ActiveSheet

    Sheets("Input DATA").Select
    Range("B2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Set a = Selection

Sheets("SAP Output DATA").Select
For Each b In a.Rows
MsgBox b.Address

    For Each Address In b

    coltoSearch = "A"
    For i = 2 To Range(coltoSearch & Rows.Count).End(xlUp).row
    Set r = Range(coltoSearch & i)

        If Len(r.Value) = 0 Then
            MsgBox "No Value, in " & r.Address
            b.Copy Destination:=Cells(i, 5)
        End If

    Next i

    Next Address
Next b

End Sub

Excel表格下载问题：

https://drive.google.com/file/d/0B-ZY6BZH9zh5WGpuY0RPZk5Mb2c/view?usp=sharing

按钮被调用＆＃34;将文本复制到颜色＆＃34;在SAP数据表

到目前为止，我唯一能以一种有效的方式工作。我不知道为什么它有时会失败;是这样的：

Sub WorkingLoop()
    Dim a As Range, b As Range, d As Range, f As Range, e As Range
    Dim i As Long, r As Range, coltoSearch As String
    Dim sht As Worksheet

    Set sht = ThisWorkbook.Worksheets("Input DATA")

    Sheets("Input DATA").Select
    Range("B2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Set a = Selection

Sheets("SAP Output DATA").Select

For Each b In a.Rows
'MsgBox b.Address

Set f = sht.Range(b.Address)
f.Copy
    coltoSearch = "A"
    For i = 2 To Range(coltoSearch & Rows.Count).End(xlUp).row
    Set r = Range(coltoSearch & i)


        If Len(r.Value) = 0 Then
            'MsgBox "No Value, in " & r.Address
            Set e = Range(r.Address)

            For Each cell In e
            e.PasteSpecial
            Next cell
        End If

    Next i
e.PasteSpecial
Next b


End Sub

3 个答案:

答案 0 :(得分：2)

由于两张图片上的数据与复制和粘贴不匹配，因此仍然不能过分肯定您所追求的内容。我已经写了几个程序，展示如何排序和复制粘贴 - 无需选择。

我建议在＆＃39; With＆＃39;和＆＃39;细胞＆＃39;用于更好地理解代码的关键字。

<script src="https://ajax.googleapis.com/ajax/libs/jquery/2.1.1/jquery.min.js"></script>
<div id="loader"></div>

答案 1 :(得分：0)

截至目前，这是工作循环。

Sub Testshttestonemoretime()
'http://stackoverflow.com/questions/18875115/go-to-first-blank-row
'http://www.contextures.com/xlDataEntry02.html
'http://stackoverflow.com/questions/20805874/excel-vba-copy-and-paste-loop-within-loop
'http://stackoverflow.com/questions/1463236/loop-through-each-row-of-a-range-in-excel
'http://stackoverflow.com/questions/28202581/copy-and-paste-in-first-blank-row-loop


    Dim a As Range, b As Range, d As Range, f As Range, e As Range
    Dim i As Long, r As Range, coltoSearch As String
    Dim sht As Worksheet

    Set sht = ThisWorkbook.Worksheets("Input DATA")

    Sheets("Input DATA").Select
    Range("B2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Set a = Selection

Sheets("SAP Output DATA").Select

For Each b In a.Rows
'MsgBox b.Address

Set f = sht.Range(b.Address)
f.Copy
    coltoSearch = "A"
    For i = 2 To Range(coltoSearch & Rows.Count).End(xlUp).row
    Set r = Range(coltoSearch & i)


        If Len(r.Value) = 0 Then

            'MsgBox "No Value, in " & r.Address
            'b.Copy Destination:=Cells(i, 5)
            Set e = Range(r.Address)
            'f.Copy Destination:=Cells(i, 5)
            'e.Cells(i, 5).Value = f.Value
            For Each cell In e
            e.PasteSpecial
            Selection.Interior.ColorIndex = 17
            Next cell

        End If

    Next i

'f.Copy Destination:=e
On Error GoTo ErrHandler
'e.Offset(0, 4).PasteSpecial
e.PasteSpecial
Selection.Interior.ColorIndex = 17
ErrHandler:
Next b

End Sub

Loop以这种方式运行：

Sub runallsubssap()
Dim shl
Set shl = CreateObject("WScript.Shell")

application.ScreenUpdating = False
Call Testshttestonemoretime
shl.Run "c:\temp\1000.vbs", 1, True
Call OffsetColoredCells
shl.Run "c:\temp\1000.vbs", 1, True
Call insertselection
shl.Run "c:\temp\1000.vbs", 1, True
Call Selecterange
shl.Run "c:\temp\1000.vbs", 1, True
Call ColorBlankCells
application.ScreenUpdating = True

End Sub

并解决选择每个单元格并抵消它的问题，我只是插入了它。 

Sub OffsetColoredCells()
Dim rngSrch As Range, C As Range

    Dim rCell As Range
    Dim lColor As Long
    Dim rColored As Range

Sheets("SAP Output DATA").Select
Range(Cells(2, "A"), Cells(Rows.Count, "E").End(xlUp)).Select

l7Color = RGB(153, 153, 255)

            Set rColored = Nothing
            For Each rCell In Selection
                If rCell.Interior.Color = l7Color Then
                    If rColored Is Nothing Then
                        Set rColored = rCell
                        'GoTo NextSheet1
                    Else
                       Set rColored = Union(rColored, rCell)
                    End If

                End If
            Next

            'If rColored Is Nothing Then
            '    MsgBox "Nothing is Selected"
            'Else

rColored.Select

End Sub

Sub insertselection()

    application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

End Sub

Sub Selecterange()

    Range("E2").Select
    Call ColumnSelectAndSelect(4)
    Selection.Offset(0, 1).Select
    Selection.Delete Shift:=xlToLeft

End Sub

答案 2 :(得分：0)

使用完最后一个循环后，它所做的只是复制粘贴1行，然后只在所有行的末尾添加另一行，但是这会选择每个空行Range（＆＃34; D2＆＃34;）是自定义范围，定义为工作表中的第一个起始空白行。这需要按项目定义。然后它做一个正常的循环。最后的错误确定它是否到达结尾并且页面达到第一个范围。对不起，这是一个简单的解决方案。以上答案是不正确的。我以为是。 

Sub PasteinBlankCellsLoop()
Dim sht As Worksheet
Dim i As Long, lastrow As Long
Dim lColumn As Long

Set sht = ThisWorkbook.Sheets("Input DATA")

ThisWorkbook.Sheets("SAP Output DATA").Select
Range("D2").Select

With sht
On Error GoTo Beginning:
lColumn = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).row

For i = 2 To lastrow
    For x = 1 To lColumn

        Range((sht.Cells(i, 1)), sht.Cells(i, sht.Columns.Count).End(xlToLeft)).Copy

        Selection.PasteSpecial
        Selection.Interior.ColorIndex = 17
        ActiveCell.Offset(1, 0).End(xlDown).Select
        ActiveCell.Offset(1, 0).Select
        Range(ActiveCell, ActiveCell.Offset(0, x)).Select

    Next x
Next i
End With

Beginning:
Range("A1").Select

End Sub

更新它以计算列范围..就是这样......这是完美的......

相关问题
最新问题