VBA copy and paste

[londa_vba]

Hello
I need to copy from three different excel sheets ("G", "R", and "Y") from the same cell ranges (B10:B33,B39:B64,B70:B95,B101:B126) on all three sheets and paste onto sheet "C" starting with cell C5. I would like the code to remove the blank cells (all cells have formulas in them so by blank I guess I mean no value from formula results) and I would like the pasted list to be continuous (wherever G finishes R begins right beneath it, etc.) I have tried several available codes online but I do not understand vba enough to adjust them to my specific needs. Thank you

 

[duggie33]

What version of Excel are you using?

Please update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using, as the best solution often varies by version. Don’t forget to scroll down to save your changes.

Doug

 

[RobP]

Would you be able to update your profile with the version of Excel you are using please ?

That way people know what kind of armoury they can use when looking at solutions for you

 

[Herakles]

Hello
I need to copy from three different excel sheets ("G", "R", and "Y") from the same cell ranges (B10:B33,B39:B64,B70:B95,B101:B126) on all three sheets and paste onto sheet "C" starting with cell C5. I would like the code to remove the blank cells (all cells have formulas in them so by blank I guess I mean no value from formula results) and I would like the pasted list to be continuous (wherever G finishes R begins right beneath it, etc.) I have tried several available codes online but I do not understand vba enough to adjust them to my specific needs. Thank you

Does this work?

Try it on a copy of your data.

Private Sub VBAcopyandpaste()
Dim arrRanges() As String
Dim arrWorksheets() As String
Dim Ws As Worksheet
Dim i As Integer
Dim ii As Integer
Dim intRow As String
Dim rng As Range

    ActiveWorkbook.Save
    
    Worksheets("C").Activate
    
    With Worksheets("C")
        .Range("C5:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value = ""
    End With

    arrRanges = Split("B10:B33,B39:B64,B70:B95,B101:B126", ",")
        
    arrWorksheets = Split("G,R,Y", ",")
    
    intRow = 5
    
    For i = LBound(arrWorksheets) To UBound(arrWorksheets)
        
        For ii = LBound(arrRanges) To UBound(arrRanges)
            
            For Each rng In Worksheets(arrWorksheets(i)).Range(arrRanges(ii))
                If Len(Trim(rng.Value)) > 0 Then
                    Worksheets("C").Cells(intRow, 3).Value = rng.Value
                    intRow = intRow + 1
                End If
            Next rng
            
        Next ii
        
    Next i
    
    Worksheets("C").Range("C5").Select
    
    MsgBox intRow - 5 & " rows of data copied", vbOKOnly, "Confirmation"
            
End Sub

 

[londa_vba]

Does this work?

Try it on a copy of your data.

Private Sub VBAcopyandpaste()
Dim arrRanges() As String
Dim arrWorksheets() As String
Dim Ws As Worksheet
Dim i As Integer
Dim ii As Integer
Dim intRow As String
Dim rng As Range

    ActiveWorkbook.Save
   
    Worksheets("C").Activate
   
    With Worksheets("C")
        .Range("C5:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value = ""
    End With

    arrRanges = Split("B10:B33,B39:B64,B70:B95,B101:B126", ",")
       
    arrWorksheets = Split("G,R,Y", ",")
   
    intRow = 5
   
    For i = LBound(arrWorksheets) To UBound(arrWorksheets)
       
        For ii = LBound(arrRanges) To UBound(arrRanges)
           
            For Each rng In Worksheets(arrWorksheets(i)).Range(arrRanges(ii))
                If Len(Trim(rng.Value)) > 0 Then
                    Worksheets("C").Cells(intRow, 3).Value = rng.Value
                    intRow = intRow + 1
                End If
            Next rng
           
        Next ii
       
    Next i
   
    Worksheets("C").Range("C5").Select
   
    MsgBox intRow - 5 & " rows of data copied", vbOKOnly, "Confirmation"
           
End Sub

THIS WORKS PERFECTLY!!! genius. thank you

 

[londa_vba]

What version of Excel are you using?

Please update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using, as the best solution often varies by version. Don’t forget to scroll down to save your changes.

Doug

Hi Doug, would this be version 2303? I did not see that as an option under account details.

 

[Fluff]

That's the build version, you need the product version, such as 365, 2021 etc

 

[duggie33]

If you click the "About Excel" button it should tell you the product version near the top of the popup window. It will be something like 365, 2021, 2019, 2016, etc.

Doug

 

[londa_vba]

Does this work?

Try it on a copy of your data.

Private Sub VBAcopyandpaste()
Dim arrRanges() As String
Dim arrWorksheets() As String
Dim Ws As Worksheet
Dim i As Integer
Dim ii As Integer
Dim intRow As String
Dim rng As Range

    ActiveWorkbook.Save
   
    Worksheets("C").Activate
   
    With Worksheets("C")
        .Range("C5:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value = ""
    End With

    arrRanges = Split("B10:B33,B39:B64,B70:B95,B101:B126", ",")
       
    arrWorksheets = Split("G,R,Y", ",")
   
    intRow = 5
   
    For i = LBound(arrWorksheets) To UBound(arrWorksheets)
       
        For ii = LBound(arrRanges) To UBound(arrRanges)
           
            For Each rng In Worksheets(arrWorksheets(i)).Range(arrRanges(ii))
                If Len(Trim(rng.Value)) > 0 Then
                    Worksheets("C").Cells(intRow, 3).Value = rng.Value
                    intRow = intRow + 1
                End If
            Next rng
           
        Next ii
       
    Next i
   
    Worksheets("C").Range("C5").Select
   
    MsgBox intRow - 5 & " rows of data copied", vbOKOnly, "Confirmation"
           
End Sub

Sorry to bother you again but I needed to move the paste site on the code solution you gave me and now it is pasting where I would like AA3 on Sheet C but I am getting an error message regarding line 29 type mismatch

Sub PopulateCEPrep()
Dim arrRanges() As String
Dim arrWorksheets() As String
Dim Ws As Worksheet
Dim i As Integer
Dim ii As Integer
Dim intRow As String
Dim rng As Range

    ActiveWorkbook.Save
    
    Worksheets("Sheet C").Activate
    
    With Worksheets("Sheet C")
        .Range("AA3:AA" & .Cells(.Rows.Count, "AA").End(xlUp).Row).Value = ""
    End With

    arrRanges = Split("B8:B33,B39:B64,B70:B95,B101:B126", ",")
        
    arrWorksheets = Split("G,R,Y", ",")
    
    intRow = 3
    
    For i = LBound(arrWorksheets) To UBound(arrWorksheets)
        
        For ii = LBound(arrRanges) To UBound(arrRanges)
            
            For Each rng In Worksheets(arrWorksheets(i)).Range(arrRanges(ii))
                If Len(Trim(rng.Value)) > 0 Then
                    Worksheets("Sheet C").Cells(intRow, 27).Value = rng.Value
                    intRow = intRow + 1
                End If
            Next rng
            
        Next ii
        
    Next i
    
    Worksheets("Sheet C").Range("AA3").Select
    
    'MsgBox intRow - 5 & " rows of data copied", vbOKOnly, "Confirmation"

 

[StephenCrump]

... Coming in from duplicate post here: mismatch error

What is the exact error message you are getting? And on which line of code?

If you have an error value anywhere in the ranges "B8:B33,B39:B64,B70:B95,B101:B126" in worksheets "G", "R" or "Y", you will get a Run-time error '13': Type mismatch error when you test the cell value on this line of code:

If Len(Trim(rng.Value)) > 0 Then