looping through range and copying to range

Question

I am having a really hard time copying rows from a loop to a loop. The destiniation loop is all blank cells. I have been stuck on this for 3 days now, i feel so unproductive. What am i missing?

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

It copies the data over, but the data it copies over is all original data from row 2, the next blank cell doesnt contain the next row data from the Input DATA sheet. How can i loop through the rows and paste them into the blank cells?

see images:

1. https://i.stack.imgur.com/Jd95G.png

2. https://i.stack.imgur.com/444RO.png

After a long day, i still cant solve it. This is as close as i think ill ever get it.

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 Sheet to download with the problem:

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

the button is called "Copy text to color" on sap data sheet

so Far the only thing i got working in a way that works, mostly. I have no idea why it fails sometimes; is this:

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

Not quite sure what you're trying to do. Is it: copy all data from row 2 down on the "SAP Output Data" to the bottom of the "Input data" sheet and do (or not do) something with blank cells? — Darren Bartrup-Cook, Jul 27 '15 at 15:58
I removed the redundant code. Sorry that was confusing you're right. I want to copy each individual row from one range to another range and in the destination range (blanks) will be filled in order from the source range. — DeerSpotter, Jul 27 '15 at 16:19
Still not quite getting it - so, for example, your data on 'SAP Output Data' covers rows 1 to 15. You have data on the 'Input Data' sheet - the data covers rows 1 to 3, then there's 3 blank columns, then a few more rows of data followed by blank rows - you want the data from 'SAP Output Data' pasting into blank rows 1 to 3, and then the rest of it into the other blank rows? If this is the case - would it not be better to sort 'Input Data' first, which will bring all data to the top and then just paste below that? — Darren Bartrup-Cook, Jul 27 '15 at 16:27

score 2 · Answer 1 · answered Jul 27 '15 at 19:21

Still not overly sure what you're after as the data on the two images doesn't match for copying and pasting. I've written a couple of procedures showing how to sort and copy paste - without selecting.

I'd suggest looking up help on the 'With' and 'Cells' keywords for a better understanding of the code.

Sub CopyPaste()

    Dim wrkBkTarget As Workbook, wrkShtTarget As Worksheet
    Dim wrkBkSource As Workbook, wrkShtSource As Worksheet
    Dim rLastCellSrc As Range, rLastCellTgt As Range

    'Update these to reference your workbooks.
    'If both sheets are in the workbook containing this code then
    'you can remove these references - just set each worksheet reference to ThisWorkbook
    Set wrkBkTarget = ThisWorkbook
    Set wrkBkSource = ThisWorkbook

    'Update to reference your worksheets.
    Set wrkShtTarget = wrkBkTarget.Worksheets("Input DATA")
    Set wrkShtSource = wrkBkSource.Worksheets("SAP Output DATA")

    Set rLastCellTgt = LastCell(wrkShtTarget)
    Set rLastCellSrc = LastCell(wrkShtSource)

    'First sort the target sheet and find the new last cell.
    'Sorts on column A.
    With wrkShtTarget
        .Sort.SortFields.Add Key:=.Range(.Cells(1, 1), .Cells(rLastCellTgt.Row, 1)), Order:=xlAscending
        With .Sort
            .SetRange wrkShtTarget.Range(wrkShtTarget.Cells(1, 1), rLastCellTgt)
            .Header = xlYes
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    'Find the new last cell - you need to paste on next row down.
    Set rLastCellTgt = LastCell(wrkShtTarget)

    'Now copy the new data to the bottom of the dataset.
    With wrkShtSource
        .Range(.Cells(2, 1), rLastCellSrc).Copy _
            Destination:=wrkShtTarget.Cells(rLastCellTgt.Row + 1, 1)
    End With

End Sub


'Returns a reference to the last cell on the sheet - useful in most projects.
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

hey, it really messes up my whole sheet. Can i send you my excel sheet so you could take a look at it? To see exactly the dilemma? — DeerSpotter, Jul 27 '15 at 20:15
I know i should of been more specific, the button is called "Copy text to color" on sap data sheet — DeerSpotter, Jul 27 '15 at 20:34

score 0 · Answer 2 · answered Jul 29 '15 at 14:11

As of now this is the working loop.

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 is run this way:

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

and to solve selecting each cell and offsetting it, i just did a insert to it.

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

DeerSpotter · Accepted Answer · 2015-08-03T16:36:44.173

After Working with the last loop all it did was Copy paste 1 row in and then only add another row at the end of all the row, this however selects each empty row Range("D2") is a custom range defined of the first starting blank row in the sheet. This needs to be defined per project. Then it does a normal loop. The error at the end determines if it reaches the end and pages up to first range. Sorry guys this was a easy solution to a hard question. The above answer isnt correct. I assumed it was.

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

updated it to count columns range.. that is it... this is perfect...

i will try to make a screen video of this in action. This is a amazing piece of work, i think once you all see it work, you will realize what was accomplished. — DeerSpotter, Jan 18 '17 at 20:36

looping through range and copying to range

3 Answers3