我很难将行从循环复制到循环。目标循环是所有空白单元格。我已经被困在这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
答案 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
更新它以计算列范围..就是这样......这是完美的......