Need help copying data

OfficeUser

Well-known Member
Joined
Feb 4, 2010
Messages
542
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I need to copy data from one sheet to another. I use this code to find the first empty row.
Code:
Sub MoveTrackingData()
    Worksheets("Main").Range("B2").Copy
    Worksheets("Track").Select
    Range("A1000").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
End Sub

Cell B2 on "Main" will always hold a value so it will always be copied to the first empty cell in column A on sheet "Track". I also would like to copy all the values held in B3:B10, B12 to the same row on the sheet "Track".

I could write a similar macro for each cell I need to copy but not every cell on "Main" will always have a value, so my data would end up getting jumbled. How do I say that when it finds the first empty row, for example if its row 46, so that "Track"A46 = "Main"B2, "Track"B46 = "Main"B3 , "Track"C46 = "Main"B4, and so on?

Thanks.
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
See if this works for you.

Code:
Sub MoveTrackingData()
    Worksheets("Main").Range("B2:B10").Copy
    Worksheets("Track").Select
    Range("A1000").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Worksheets("Main").Range("B12").Copy
     Range("A1000").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, 9).Select
    Selection.PasteSpecial Paste:=xlPasteValues
End Sub
 
Upvote 0
To clarify, you want to find every non-blank value in column B in "Main" and want to paste them across the last row in "Track"?
 
Upvote 0
Try:

Code:
Public Sub OfficeUser()
Dim i   As Long, _
    LR  As Long, _
    LR2 As Long, _
    col As Long
    
col = 1
LR = Sheets("Main").Range("A" & Rows.Count).End(xlUp).row
LR2 = Sheets("Track").Range("A" & Rows.Count).End(xlUp).row + 1
Application.ScreenUpdating = False
For i = 2 To LR
    If Sheets("Main").Range("B" & i).Value <> "" Then
        Sheets("Track").Range("B" & i).Copy Destination:=Sheets("Track").Cells(LR2, col)
        col = col + 1
    End If
Next i
Application.ScreenUpdating = True
End Sub
 
Upvote 0
MrKowz:

This works after a slight correction to sheet names. The only thing I see not working is that when it copies the values in "Main" B5 & B6, it is not showing the true values in the cells on the "Track" sheet. This could be because "Main" B5 & B6 have a simply formula in them such as =B30 and
=B31. Thanks.
 
Upvote 0
See if this works for you.

Code:
Sub MoveTrackingData()
    Worksheets("Main").Range("B2:B10").Copy
    Worksheets("Track").Select
    Range("A1000").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Worksheets("Main").Range("B12").Copy
     Range("A1000").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, 9).Select
    Selection.PasteSpecial Paste:=xlPasteValues
End Sub

This works good but the value in "Main"B12 is not copieed over to "Track"...? Thanks.
 
Upvote 0
Try:

Code:
Public Sub OfficeUser()
Dim i   As Long, _
    LR  As Long, _
    LR2 As Long, _
    col As Long
    
col = 1
LR = Sheets("Main").Range("A" & Rows.Count).End(xlUp).row
LR2 = Sheets("Track").Range("A" & Rows.Count).End(xlUp).row + 1
Application.ScreenUpdating = False
For i = 2 To LR
    If Sheets("Main").Range("B" & i).Value <> "" Then
        Sheets("Track").Range("B" & i).Copy
        Sheets("Track").Cells(LR2, col).PasteSpecial Paste:=xlValues
        col = col + 1
    End If
Next i
Application.ScreenUpdating = True
End Sub
 
Upvote 0
That did the trick. I was fairly close in getting to a solution myself. I had a few errors but was on the right track. Thanks to you both for helping.
 
Upvote 0
For what it's worth, here's a non-looping way that seems to work as well:

Code:
Public Sub OfficeUser_No_Loop()
Dim LR  As Long, _
    LR2 As Long

LR = Sheets("Main").Range("A" & Rows.Count).End(xlUp).Row
LR2 = Sheets("Track").Range("A" & Rows.Count).End(xlUp).Row + 1
Application.ScreenUpdating = False
Sheets("Main").Range("$B$1:$B$" & LR).AutoFilter Field:=1, Criteria1:="<>"
Sheets("Main").Range("B2:B" & LR).Copy
Sheets("Track").Range("B" & LR2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
Sheets("Main").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

Should be a bit faster than the looping method above.
 
Upvote 0

Forum statistics

Threads
1,213,561
Messages
6,114,316
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top