Offset after loop

horizonflame

Board Regular
Joined
Sep 27, 2018
Messages
151
Hi All

I would like to copy all non-blank cells in range R5:X7000 into the adjacent cell in Range K5:Q7000 as paste values. Essentially any non-blank cells will paste as a value in same row but 7 columns to the left. I have what I think is a good piece of code but need some help how to edit it to my cell range and paste area.

Code:
Sub CopyData()    Application.ScreenUpdating = False
    Dim c As Range
    For Each c In Range("K5:Q7000")
        If c.Offset(0, 1) <> "" Then     NEED TO CHANGE THIS LINE
            c.Copy
            Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)   NEED TO CHANGE THIS LINE
            Application.CutCopyMode = False
        End If
    Next c
    Application.ScreenUpdating = False
End Sub
Many thanks
 
Last edited:

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,458
Office Version
365, 2010
Platform
Windows
Re: Help with Offset after loop

I am a little confused with exactly how you want to deal with the non blank cells. if a cell is blank and you want it to go away then any cells to the right of the blank are going to move more than 7 rows to the left depending on how many blanks there are in that row. That said, does this get you any closer to what you want.

Code:
Sub moveValues()


    Dim c As Long, r As Long, c1 As Long, r1 As Long
    Dim arr, noblk(1 To 6996, 1 To 7)
    
    arr = Range("R5:X7000")
    c1 = 1: r1 = 1
    For c = 1 To 6996
        For r = 1 To 7
            If Not arr(c, r) = Empty Then
                noblk(c1, r1) = arr(c, r)
                r1 = r1 + 1
            End If
        Next
        c1 = c1 + 1
        r1 = 1
    Next
    Range("K5").Resize(UBound(noblk, 1), UBound(noblk, 2)) = noblk


End Sub
 

horizonflame

Board Regular
Joined
Sep 27, 2018
Messages
151
Re: Help with Offset after loop

Apologies, let me explain in more detail in case that helps a better solution.

With Column R I want to copy any Rows that contain dates into the adjacent Column K and paste as values. And repeat with Column S into column L etc for all 7 columns. The range contains either dates or blank cells.

I thought offset was the right thing to try but I don’t quite understand how that works yet.

Many thanks
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,478
Office Version
365
Platform
Windows
Re: Help with Offset after loop

Try:

Code:
  Range("R5:X7000").Copy
  Range("K5").PasteSpecial Paste:=xlPasteValues, [COLOR=#0000cd]SkipBlanks:=True[/COLOR]
 

horizonflame

Board Regular
Joined
Sep 27, 2018
Messages
151
Re: Help with Offset after loop

That’s brilliantly simple, thank you!
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,478
Office Version
365
Platform
Windows
Re: Help with Offset after loop

You're welcome, glad to help, & thanks for the feedback.:)
 

horizonflame

Board Regular
Joined
Sep 27, 2018
Messages
151
Re: Help with Offset after loop

Hey @Akuini, apologies but I've found it will copy all cells in the range. It may be because they are not truely blank but have a formula that returns a "" result. Could that be tweaked at all?

Thanks
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,458
Office Version
365, 2010
Platform
Windows
Re: Help with Offset after loop

Can you show a small sample of the before and after that you expect....

Do you want the cells that contain formulas to be copied back as blank cells with no formula. If that is the case, how about this...

Code:
Sub moveValues()


    Dim arr
    
    arr = Range("R5:X7000")
    Range("K5").Resize(UBound(arr, 1), UBound(arr, 2)) = arr


End Sub
 
Last edited:

horizonflame

Board Regular
Joined
Sep 27, 2018
Messages
151
Re: Help with Offset after loop

Column ROriginal Column KNew Column K
24/10/201924/10/2019
20/10/201920/10/2019
21/10/201921/10/2019
26/10/201926/10/2019
25/10/2019
25/10/2019
28/10/201928/10/2019
30/10/201930/10/2019

<tbody>
</tbody>


Hi @igold, i have done an example column with expected result above. I am looking for Columns R:X to go into K:Q and combine with the existing data, I don't want to overwrite the existing data. The blanks are "" formula results so I want to ignore them to avoid the overwriting.

Thanks again
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,458
Office Version
365, 2010
Platform
Windows
Re: Help with Offset after loop

Does this do what you want...

Code:
Sub movevalues2()

    Dim rngRx As Range, rngKQ As Range
    Dim i As Long
    
    Set rngRx = Range("R5:X7000")
    Set rngKQ = Range("K5:Q7000")
    For i = 1 To 6996
        If Not rngRx.Cells(i) = "" And rngKQ.Cells(i) = "" Then
            rngKQ.Cells(i) = rngRx.Cells(i)
        End If
    Next
    
End Sub
 
Last edited:

Forum statistics

Threads
1,085,544
Messages
5,384,350
Members
401,888
Latest member
nisabina

Some videos you may like

This Week's Hot Topics

Top