VBA Modification help - copy data from columns to another column

L

lawi227

Board Regular
Joined
Mar 17, 2016
Messages
123
This is my current attempt at copying data from one tab and pasting into a table on a different tab. I began modifying the code below. The text highlighted in yellow is where I need help.

Essentially, here are the two scenarios:
ONE-
If F5 on the "Instructions" tabs = 1, then copy columns H:J starting at row 4 on sheet "Selected LP List" to the last three empty columns on the sheet "LPA Database Raw Data". NOTE: The range for the columns where the text should be copied into are F:EY and start at row 5

TWO-
If F5 on the "Instructions" tabs = 2, then copy columns H:J and L:N starting at row 4 on sheet "Selected LP List" to the last six empty columns on the sheet "LPA Database Raw Data". NOTE: The range for the columns where the text should be copied into are F:EY and start at row 5


This formula below worked well for me when I was copying data. It identified the last row, but I have re-organized my worksheets and now I am looking at the columns.



<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; background-color: #ffffff; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #008f00; background-color: #ffffff}p.p4 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993; background-color: #ffffff}span.s1 {color: #011993}span.s2 {color: #000000}</style>
Public Sub PasteToLastRow()


Dim instructionsSheet As Worksheet
Dim databaseSheet As Worksheet
Dim lastRow As Long


Set instructionsSheet = Sheets("Instructions")
Set databaseSheet = Sheets("LPA Database Scores")


lastRow = databaseSheet.Range("C118").End(xlUp).Row + 1
If lastRow = 118 Then
' No more spare rows
Exit Sub
End If


' Copy the data
databaseSheet.Range("B56:AQ57" & CStr(5 + instructionsSheet.Range("F5").Value)).Copy
databaseSheet.Cells(lastRow, 2).PasteSpecial Paste:=xlPasteValues


End Sub
<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; background-color: #ffffff; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #008f00; background-color: #ffffff}p.p4 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993; background-color: #ffffff}span.s1 {color: #011993}span.s2 {color: #000000}</style><style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}span.s1 {color: #011993}</style>
 
Sort by date Sort by votes
Soo.. the code worked! HOWEVER, I realized a flaw in my data....

I'll try to explain the best I can: This worksheet has raw data. Everytime I use the workbook, and run an assessment, it spits out 3 columns of data. Hence the reason why I am copying columns H, I, & J. However, during one assessment, I only had data for 1 of the three. Therefore, when I pasted the data, I only pasted data from H. I had to keep blanks from columns I & J. So what happened in my 'Database Raw Data' tab is there is data in column AS, but blanks in columns AT & AU. However, in column AV, there is more data from a separate assessment. Your formula correctly identified AT as being blank, however, it wasn't ultimately the column I was hoping for.

I think this can be resolved by looking for 3 consecutive columns with all blanks. Can that be done?

I am so so sorry to keep asking for iterations to the code. But it is truly very helpful and something I will use in the future. Thanks!
 
Upvote 0

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
UPDATE (additional request with this code):
Since I'm asking for an update (thanks once again), I had one other VBA code that could be helpful... I think it would be easiest to provide an example:

Let's say F5=1 on the instructions tab. When I run the macro, cells H:J on the instructions tab are pasted into BN5:BP741. I would like cell F6 on the instructions tab to be pasted into BN3 on the lpa database raw data and I would like cell F4 to be pasted into BN2.

Let's say F6=2 on the instructions tab. When I run the macro, cells H:J on the instructions tab are pasted into BN5:BP741 and L:N is pasted to BQ5:BQ741. I would like cell F6 on the instructions tab to be pasted into BN3 on the lpa database raw data and I would like cell F4 to be pasted into BN3. I would then like cell F7 to be pasted into BQ3 and cell F4 to be pasted into BQ2.

Note: F4 is pasted into BN2 and BQ2. That is not a typo. And also, BN3, BN2, BQ3 and BQ2 are each three merged cells. For example.. BN3 and BN2 is a merged column across BN:BP. I don't think this has any implications on VBA but I wanted to let you know.
 
Upvote 0
lawi227 said:
UPDATE (additional request with this code):
Since I'm asking for an update (thanks once again), I had one other VBA code that could be helpful... I think it would be easiest to provide an example:

Let's say F5=1 on the instructions tab. When I run the macro, cells H:J on the instructions tab are pasted into BN5:BP741. I would like cell F6 on the instructions tab to be pasted into BN3 on the lpa database raw data and I would like cell F4 to be pasted into BN2.

Let's say F6=2 on the instructions tab. When I run the macro, cells H:J on the instructions tab are pasted into BN5:BP741 and L:N is pasted to BQ5:BQ741. I would like cell F6 on the instructions tab to be pasted into BN3 on the lpa database raw data and I would like cell F4 to be pasted into BN3. I would then like cell F7 to be pasted into BQ3 and cell F4 to be pasted into BQ2.

Note: F4 is pasted into BN2 and BQ2. That is not a typo. And also, BN3, BN2, BQ3 and BQ2 are each three merged cells. For example.. BN3 and BN2 is a merged column across BN:BP. I don't think this has any implications on VBA but I wanted to let you know.
Click to expand...

You are adding mud to the water :)

For clarity are we now cutting out the "Selected LP List" and copying from the "Instructions" sheet and pasting to? Previous instructions were copying from "Selected LP List"

Once clarity is provided I should be able to accommodate the 3 consecutive empty columns etc.
 
Last edited:
Upvote 0
I know.. And I know my ask isn't easy. :eeek:

The copy and pasting columns H:J, etc. from "Selected LP List" is correct how you have it (I just need to find the first column that is 100% blank that also has two consecutive columns to its right that are also 100% blank). The updated request requires copying and pasting data that is on the "Instructions" tab.

So in short - The text in red was incorrect because columns H:J and L:N are still on the "Selected LP List" tab.

Did that answer your question?
 
Upvote 0
If I understood your instructions correctly this should do what you need.

Code: 
Sub Test()

Dim LastCol As Integer


If Sheets("Instructions").Range("F5") = 1 Then


    Sheets("Selected LP List").Range("H4:J740").Copy
    
    Sheets("LPA Database Raw Data").Activate
    
    With ActiveSheet
        LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        
        RLastCol = False
        
        Do Until RLastCol = True
        
        For i = 5 To 740
        
        If Cells(i, LastCol).Value = "" And Cells(i, LastCol + 1).Value = "" And Cells(i, LastCol + 2).Value = "" Then
        Else
        LastCol = LastCol + 1
        Exit For
        
        End If
    
        Next i
        
        If i = 741 And Cells(i, LastCol).Value = "" Then
        RLastCol = True
        End If
        
        Loop
        
    End With
        
    If LastCol >= 154 Then
    MsgBox ("You are out of available space")
    Exit Sub
    ElseIf LastCol < 6 Then
    LastCol = 5
    End If
        
    Sheets("LPA Database Raw Data").Cells(5, LastCol).PasteSpecial (xlPasteValues)
    
    Sheets("Instructions").Range("F4").Copy
    Sheets("LPA Database Raw Data").Cells(2, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(2, LastCol), Cells(2, LastCol + 2)).Merge
    
    Sheets("Instructions").Range("F6").Copy
    Sheets("LPA Database Raw Data").Cells(3, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(3, LastCol), Cells(3, LastCol + 2)).Merge
    
    
    
ElseIf Sheets("Instructions").Range("F5") = 2 Then


    Sheets("Selected LP List").Range("H4:J740").Copy
    
    Sheets("LPA Database Raw Data").Activate
    
    With ActiveSheet
        LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        
        RLastCol = False
        
        Do Until RLastCol = True
        
        For i = 5 To 740
        
        If Cells(i, LastCol).Value = "" And Cells(i, LastCol + 1).Value = "" And Cells(i, LastCol + 2).Value = "" Then
        Else
        LastCol = LastCol + 1
        Exit For
        
        End If
    
        Next i
        
        If i = 741 And Cells(i, LastCol).Value = "" Then
        RLastCol = True
        End If
        
        Loop
        
    End With
        
    If LastCol >= 151 Then
    MsgBox ("You are out of available space")
    Exit Sub
    ElseIf LastCol < 6 Then
    LastCol = 5
    End If
        
    Sheets("LPA Database Raw Data").Cells(5, LastCol).PasteSpecial (xlPasteValues)
    
    Sheets("Instructions").Range("F4").Copy
    Sheets("LPA Database Raw Data").Cells(2, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(2, LastCol), Cells(2, LastCol + 2)).Merge
    
    Sheets("Instructions").Range("F6").Copy
    Sheets("LPA Database Raw Data").Cells(3, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(3, LastCol), Cells(3, LastCol + 2)).Merge
    
    


    Sheets("Selected LP List").Range("L4:N740").Copy
    
    Sheets("LPA Database Raw Data").Activate
    
    With ActiveSheet
        LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        
        RLastCol = False
        
        Do Until RLastCol = True
        
        For i = 5 To 740
        
        If Cells(i, LastCol).Value = "" And Cells(i, LastCol + 1).Value = "" And Cells(i, LastCol + 2).Value = "" Then
        Else
        LastCol = LastCol + 1
        Exit For
        
        End If
    
        Next i
        
        If i = 741 And Cells(i, LastCol).Value = "" Then
        RLastCol = True
        End If
        
        Loop
        
    End With
        
    If LastCol >= 151 Then
    MsgBox ("You are out of available space")
    Exit Sub
    ElseIf LastCol < 6 Then
    LastCol = 5
    End If
        
    Sheets("LPA Database Raw Data").Cells(5, LastCol).PasteSpecial (xlPasteValues)
    
    Sheets("Instructions").Range("F4").Copy
    Sheets("LPA Database Raw Data").Cells(2, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(2, LastCol), Cells(2, LastCol + 2)).Merge
    
    Sheets("Instructions").Range("F7").Copy
    Sheets("LPA Database Raw Data").Cells(3, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(3, LastCol), Cells(3, LastCol + 2)).Merge


End If


End Sub
 
Upvote 0
Hi Coding4Fun,

I'm just now getting back to this. I had to table it for some time. The code seems to work, but I do get a message. I'm hoping you can perhaps modify the code so that the message doesn't appear.

The ALERT message says: "The selection contains multiple data values. Merging into one cell will keep the upper-left most data only."

I think this is because I merged cells. For example, F1 was actually F1:H1 merged cell. Same for F2 and F3. So I had to merge them to be 3 columns wide to fit the merged cells on the "LPA database raw data” tab.



How can I get it to just automatically accept this message and run the Macro? Perhaps the only modification to the code is that it recognizes that F1 is actually F1:H1, etc.

Thanks so much! I hope this is an easy ask.



Coding4Fun said:
If I understood your instructions correctly this should do what you need.
Click to expand...
 
Upvote 0
I think it is throwing this error message when you try to merge the columns in the VBA code.

Try this I am not sure how it will result but it should not display this error, I would make sure everything looks right once your done (merged columns are right and no information was overwritten during the merge - Looks like it might merge everything into one giant cell or range)

Code: 
Sub Test()

Dim LastCol As Integer


If Sheets("Instructions").Range("F5") = 1 Then


    Sheets("Selected LP List").Range("H4:J740").Copy
    
    Sheets("LPA Database Raw Data").Activate
    
    With ActiveSheet
        LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        
        RLastCol = False
        
        Do Until RLastCol = True
        
        For i = 5 To 740
        
        If Cells(i, LastCol).Value = "" And Cells(i, LastCol + 1).Value = "" And Cells(i, LastCol + 2).Value = "" Then
        Else
        LastCol = LastCol + 1
        Exit For
        
        End If
    
        Next i
        
        If i = 741 And Cells(i, LastCol).Value = "" Then
        RLastCol = True
        End If
        
        Loop
        
    End With
        
    If LastCol >= 154 Then
    MsgBox ("You are out of available space")
    Exit Sub
    ElseIf LastCol < 6 Then
    LastCol = 5
    End If
        
    Sheets("LPA Database Raw Data").Cells(5, LastCol).PasteSpecial (xlPasteValues)
    
    Sheets("Instructions").Range("F4").Copy
    Sheets("LPA Database Raw Data").Cells(2, LastCol).PasteSpecial (xlPasteValues)
    Application.DisplayAlerts = False
     Sheets("LPA Database Raw Data").Range(Cells(2, LastCol), Cells(2, LastCol + 2)).Merge
    
    Sheets("Instructions").Range("F6").Copy
    Sheets("LPA Database Raw Data").Cells(3, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(3, LastCol), Cells(3, LastCol + 2)).Merge
     Application.DisplayAlerts = True
    
    
ElseIf Sheets("Instructions").Range("F5") = 2 Then


    Sheets("Selected LP List").Range("H4:J740").Copy
    
    Sheets("LPA Database Raw Data").Activate
    With ActiveSheet
        LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        
        RLastCol = False
        
        Do Until RLastCol = True
        
        For i = 5 To 740
        
        If Cells(i, LastCol).Value = "" And Cells(i, LastCol + 1).Value = "" And Cells(i, LastCol + 2).Value = "" Then
        Else
        LastCol = LastCol + 1
        Exit For
        
        End If
    
        Next i
        
        If i = 741 And Cells(i, LastCol).Value = "" Then
        RLastCol = True
        End If
        
        Loop
        
    End With
        
    If LastCol >= 151 Then
    MsgBox ("You are out of available space")
    Exit Sub
    ElseIf LastCol < 6 Then
    LastCol = 5
    End If
        
    Sheets("LPA Database Raw Data").Cells(5, LastCol).PasteSpecial (xlPasteValues)
    
    Sheets("Instructions").Range("F4").Copy
    Sheets("LPA Database Raw Data").Cells(2, LastCol).PasteSpecial (xlPasteValues)
    Application.DisplayAlerts = False
    Sheets("LPA Database Raw Data").Range(Cells(2, LastCol), Cells(2, LastCol + 2)).Merge
    
    Sheets("Instructions").Range("F6").Copy
    Sheets("LPA Database Raw Data").Cells(3, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(3, LastCol), Cells(3, LastCol + 2)).Merge
    Application.DisplayAlerts = True
    


    Sheets("Selected LP List").Range("L4:N740").Copy
    
    Sheets("LPA Database Raw Data").Activate
    
    With ActiveSheet
        LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        
        RLastCol = False
        
        Do Until RLastCol = True
        
        For i = 5 To 740
        
        If Cells(i, LastCol).Value = "" And Cells(i, LastCol + 1).Value = "" And Cells(i, LastCol + 2).Value = "" Then
        Else
        LastCol = LastCol + 1
        Exit For
        
        End If
    
        Next i
        
        If i = 741 And Cells(i, LastCol).Value = "" Then
        RLastCol = True
        End If
        
        Loop
        
    End With
        
    If LastCol >= 151 Then
    MsgBox ("You are out of available space")
    Exit Sub
    ElseIf LastCol < 6 Then
    LastCol = 5
    End If
        
    Sheets("LPA Database Raw Data").Cells(5, LastCol).PasteSpecial (xlPasteValues)
    
    Sheets("Instructions").Range("F4").Copy
    Sheets("LPA Database Raw Data").Cells(2, LastCol).PasteSpecial (xlPasteValues)
    Application.DisplayAlerts = False
    Sheets("LPA Database Raw Data").Range(Cells(2, LastCol), Cells(2, LastCol + 2)).Merge
    
    Sheets("Instructions").Range("F7").Copy
    Sheets("LPA Database Raw Data").Cells(3, LastCol).PasteSpecial (xlPasteValues)
    Sheets("LPA Database Raw Data").Range(Cells(3, LastCol), Cells(3, LastCol + 2)).Merge
    Application.DisplayAlerts = True

End If


End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Appending a Value to Each Element of a Range Array
Replies
7
Views
2K
Peter_SSs
Peter_SSs
K
  • Question Question
IF(ISNA...) with VLOOKUP on another worksheet to return "M" if not present on other worksheet?
Replies
4
Views
1K
Peter_SSs
Peter_SSs
charlesstricklin
  • Question Question
Calculate date given current number of days in advance
Replies
2
Views
861
charlesstricklin
charlesstricklin
A
  • Question Question
How to extract Arabic language words from list of different language
2
Replies
11
Views
7K
sandy666
sandy666
S
  • Question Question
Simulation in Excel - Best Fit
Replies
2
Views
1K
joeu2004
J

Forum statistics

Threads
1,223,919
Messages
6,175,368
Members
452,638
Latest member
Oluwabukunmi

Share this page

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