VBA code not working properly when copying and pasting info

Question

I have created a VBA to extract info from an excel file, but currently not working, and when some other times it has worked. Does anybody why is this happening now?

Sub FiltrarYcopiar()
Dim A As Integer
Dim i As Integer
Dim J As Integer


' Cuenta ultima fila

J = 1


Worksheets("Sheet1").Select
   On Error Resume Next
    A = ActiveSheet.Columns("D").Find("*", _
       searchorder:=xlByRows, searchdirection:=xlPrevious).Row
       MsgBox A


'Copia y pega

       For i = 2 To A Step 15


       J = J + 1
       
           Cells(i, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 1).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 1, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 2).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 2, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 3).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 3, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 4).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False

           
           Sheets("Sheet1").Select
           Cells(i + 5, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 6).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 6, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 7).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 7, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 8).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 8, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 9).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           
           Sheets("Sheet1").Select
           Cells(i + 10, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 11).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           
           Sheets("Sheet1").Select
           Cells(i + 11, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 12).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 11, 5).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 13).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 12, 4).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 14).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           
           Sheets("Sheet1").Select
           Cells(i + 5, 5).Select
           Selection.Copy
           Sheets("Sheet2").Select
           Cells(J, 15).Select
           Selection.PasteSpecial xlPasteValues
           Application.CutCopyMode = False
           

                
            Sheets("Sheet1").Select
        
        Next i

End Sub

Please, find as an image the info I am trying to extract from an Excel sheet in column D and paste it into another sheet ( sheet2 ). Hope the info shared is useful to find a solution. Thanks in advance!

You need to remove `On Error Resume Next` so that it will show you the error. Also, best to avoid `Activate` and `Select` — Darrell H, Apr 23 '21 at 11:16
Hi Darrel, thanks for the help! could you copy and paste the code without the parts you think are wrong? thanks! — JVA, Apr 23 '21 at 11:59
`Worksheets("Sheet1").Select` will use whichever workbook is active at the time. Obligatory post about `Activate` and `Select` - [How to avoid using select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — Darren Bartrup-Cook, Apr 23 '21 at 12:24
Most of the bottom part of your code is copying and paste special. Each block of code could be cut down to two lines: `ThisWorkbook.Worksheets("Sheet1").Cells(i + 1, 4).Copy` and `ThisWorkbook.Worksheets("Sheet2").Cells(j, 2).PasteSpecial xlPasteValues`. `ThisWorkbook` is the file containing the VBA code. — Darren Bartrup-Cook, Apr 23 '21 at 12:34

BZngr · Accepted Answer · 2021-04-23T12:49:19.400

There is a lot of extra content in the subroutine that makes finding any problem difficult. Below is a revised version of the subroutine that should be easier to debug. Hope this version helps to spot the problem.

    Option Explicit

    Sub FiltrarYcopiar()
        Dim A As Integer
        Dim i As Integer
        Dim J As Integer
        
        Dim wkshtOne As Worksheet
        Set wkshtOne = Worksheets("Sheet1")


        Dim wkshtTwo As Worksheet
        Set wkshtTwo = Worksheets("Sheet2")


        ' Cuenta ultima fila

        J = 1


        On Error Resume Next
        A = wkshtOne.Columns("D").Find("*", _
                                          searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        MsgBox A


        'Copia y pega

        For i = 2 To A Step 15


            J = J + 1
            
            CopyValue wkshtOne, i, 4, wkshtTwo, J, 1
            CopyValue wkshtOne, i + 1, 4, wkshtTwo, J, 2
            CopyValue wkshtOne, i + 2, 4, wkshtTwo, J, 3
            CopyValue wkshtOne, i + 3, 4, wkshtTwo, J, 4
            
            'Pattern skips one
            CopyValue wkshtOne, i + 5, 4, wkshtTwo, J, 6
            CopyValue wkshtOne, i + 6, 4, wkshtTwo, J, 7
            CopyValue wkshtOne, i + 7, 4, wkshtTwo, J, 8
            CopyValue wkshtOne, i + 8, 4, wkshtTwo, J, 9
            
            'Pattern skips one
            CopyValue wkshtOne, i + 10, 4, wkshtTwo, J, 11
            CopyValue wkshtOne, i + 11, 4, wkshtTwo, J, 12
            
            'Pattern changes wkshtOne Column to 5
            CopyValue wkshtOne, i + 11, 5, wkshtTwo, J, 13
            
            CopyValue wkshtOne, i + 12, 4, wkshtTwo, J, 14
            
            'Pattern changes wkshtOne Column to 5
            CopyValue wkshtOne, i + 5, 5, wkshtTwo, J, 15
            
        Next i

    End Sub

    Private Sub CopyValue(ByVal wksht1 As Worksheet, ByVal wksht1Row As Long, ByVal wksht1Col As Long, ByVal wksht2 As Worksheet, ByVal wksht2Row As Long, ByVal wksht2Col As Long)
        wksht2.Cells(wksht2Row, wksht2Col).Value = wksht1.Cells(wksht1Row, wksht1Col).Value
    End Sub

score 0 · Answer 2 · answered Apr 23 '21 at 13:08

There is no need to skip over blank cells or specify the location for each cell. It looks like you are trying to go from a column to rows in the 2nd sheet. This can be done in one operation. You can change the numbers if they are off.

Sub FiltrarYcopiar()
    Dim A As Long
    Dim i As Long
    Dim J As Long
    
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' Cuenta ultima fila
    
    J = 1
    
    A = ws1.Cells(ws1.Rows.Count, "D").End(xlUp).Row
        
    'Copia y pega

    For i = 2 To A Step 15
    
    ws1.Range(ws1.Cells(i, 4), ws1.Cells(i + 14, 4)).Copy
    ws2.Cells(J, 1).PasteSpecial xlPasteValues, Transpose:=True
    
       J = J + 1
       
    Next i
End sub

VBA code not working properly when copying and pasting info

2 Answers2