VBA - copy from one workbook and paste special values to another workbook

[Nikijune]

Hello Mr Excel,

Its been a while for me, however, I have recently started a new job that calls on my excel skills again and so here I am, looking for some guidance

I am trying to create some code that copies a range of cells, if a certain cell is populated with a number
I then want to open another workbook, find the next blank row and paste that data as special values.

I also want to loop this across all rows in the first spreadsheet. There are 36 rows in this first spreadsheet and I want to check each row individually for a value greater than 0. If that row has a value greater than 0 I want to copy the range.

I have been trying to get it to work just for one row, but cant seem to get it to paste special values into the new sheet

Here is what I have so far;

Sub TestAPR()

   'Test if the value is APR is blank/empty
   If IsEmpty(Range("U5").Value) = True Then
     ActiveSheet.Range("A5:I5").Select
     ActiveSheet.Range("A5:I5").Copy
    
     Call OpenRTEBible  
        
   End If

End Sub
______________________________________________________________________________________________________________________________________________
Sub OpenRTEBible()

Dim wb As Workbook
    Dim myfilename As String

    myfilename = "H:\RTE Bible test.xlsx"
    '~~> open the workbook and pass it to workbook object variable
    Set wb = Workbooks.Open(myfilename)
    
            
End Sub

Thanks in advance

 

[Rhodie72]

Hello Mr Excel,

Its been a while for me, however, I have recently started a new job that calls on my excel skills again and so here I am, looking for some guidance

I am trying to create some code that copies a range of cells, if a certain cell is populated with a number
I then want to open another workbook, find the next blank row and paste that data as special values.

I also want to loop this across all rows in the first spreadsheet. There are 36 rows in this first spreadsheet and I want to check each row individually for a value greater than 0. If that row has a value greater than 0 I want to copy the range.

I have been trying to get it to work just for one row, but cant seem to get it to paste special values into the new sheet

Here is what I have so far;

Sub TestAPR()

   'Test if the value is APR is blank/empty
   If IsEmpty(Range("U5").Value) = True Then
     ActiveSheet.Range("A5:I5").Select
     ActiveSheet.Range("A5:I5").Copy
   
     Call OpenRTEBible 
       
   End If

End Sub
______________________________________________________________________________________________________________________________________________
Sub OpenRTEBible()

Dim wb As Workbook
    Dim myfilename As String

    myfilename = "H:\RTE Bible test.xlsx"
    '~~> open the workbook and pass it to workbook object variable
    Set wb = Workbooks.Open(myfilename)
   
           
End Sub

Thanks in advance

Revised Code​

Try this revised version of your code that loops through rows 5 to 40 (assuming you want to loop through the first 36 rows) and pastes the data as values into the other workbook:

Sub TestAPR()

    Dim wsSource As Worksheet, wbTarget As Workbook, _
        lastRow As Long, Dim i As Long, targetRow As Long, _
        RngToCopy As Range

    ' Set the source worksheet (current active sheet)
    Set wsSource = ActiveSheet
    
    ' Open the target workbook
    Set wbTarget = Workbooks.Open("H:\RTE Bible test.xlsx")
    
    ' Find the next blank row in the target workbook (assumes data starts in row 1)
    targetRow = wbTarget.Sheets(1).Cells(wbTarget.Sheets(1).Rows.Count, "A").End(xlUp).Row + 1
    
    ' Loop through rows 5 to 40 (36 rows)
    For i = 5 To 40
        ' Check if the value in column U of the current row is greater than 0
        If wsSource.Cells(i, "U").Value > 0 Then
            ' Set the range to be copied from A to I of the current row
            Set rngToCopy = wsSource.Range("A" & i & ":I" & i)
            
            ' Copy the data
            rngToCopy.Copy
            
            ' Paste the copied data as values into the target workbook
            wbTarget.Sheets(1).Range("A" & targetRow).PasteSpecial Paste:=xlPasteValues
            
            ' Increment the targetRow for the next paste
            targetRow = targetRow + 1
        End If
    Next i
    
    ' Save and close the target workbook
    wbTarget.Save
    wbTarget.Close

    ' Clear the clipboard (optional)
    Application.CutCopyMode = False
    
    MsgBox "Data transfer complete!", vbInformationonly
End Sub

 

[MikeVol]

Hello @Nikijune.
One more option for you.

Option Explicit

Sub CopyMacros()
    Dim lastRowDest As Long, rowNum As Long

    Dim sourceWS    As Worksheet
    Set sourceWS = ThisWorkbook.ActiveSheet

    Dim lastRow     As Long
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row

    Dim iName       As String
    iName = "H:\RTE Bible test.xlsx"

    Dim destWB      As Workbook
    Set destWB = Workbooks.Open(iName)

    Dim destWS      As Worksheet
    Set destWS = destWB.Worksheets("Sheet1")   ' Replace "Sheet1" with the name of the sheet you want

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For rowNum = 5 To lastRow

        If sourceWS.Cells(rowNum, "U").Value = "" Then
            lastRowDest = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row + 1
            sourceWS.Range(sourceWS.Cells(rowNum, "A"), sourceWS.Cells(rowNum, "I")).Copy
            destWS.Cells(lastRowDest, 1).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
        End If

    Next rowNum

    destWB.Close SaveChanges:=True

    Set destWS = Nothing
    Set destWB = Nothing
    Set sourceWS = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[Rhodie72]

wherever I see

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'....a load of code followed by...
        Application.CutCopyMode =False
'....a load of code followed by...
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

I cannot help but think to EDIT THIS this way

With Application ' written 5x less but applied 6x AND you can nest With blocks!
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
 '....a load of code followed by...
             .CutCopyMode = False
'....a load of code followed by...
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

Just a thought.

With...end Withs can be nested quite nicely and reducing number of lines is a good idea

 

[MikeVol]

@Rhodie72.
It's your business and your opinion. I write as it is convenient for me and as I am used to. You could write something like that in your code, I don't see any problems.

 

[Rhodie72]

@Rhodie72.
It's your business and your opinion. I write as it is convenient for me and as I am used to. You could write something like that in your code, I don't see any problems.

Sure, but I was just saying how I cannot help thinking this way...
It's funny.
Another one is these:

    Set destWS = Nothing: Set destWB = Nothing: Set sourceWS = Nothing

Makes no difference to functionality but reduces lines to read

Do you see things that make you think it should be written differently or formatted in a different way?

 

[MikeVol]

And this is the one writing about short lines in the code that inserts comments under each line of code... Absurd... No one asked you to comment on each line of code... It would be a different matter if they asked about it, but...

 

[Nikijune]

Thanks @Rhodie72 and @MikeVol for your help with this

@MikeVol your code works to a point however its copying all rows despite some of the rows being blank in column U. I've tried playing around with it, but nothings working. Any thoughts?

 

[MikeVol]

        If sourceWS.Cells(rowNum, "U").Value > 0 Then

 

[Nikijune]

Thanks so much @MikeVol. I should have said that I had tried this and it wasn't working.

I have today realised that the cells have a formula in (someone else built the spreadsheet, I'm just butchering it further) that appears blank, however, putting < 0 seems to work

Thanks again for your help