Transfer Specific Cells Data To Another Sheet

[Rockey_01]

Hi Everyone,
I'm trying to copy some specific cells e.g. (from sheet1) A2,A4,B2,B4,C6,C8 to another sheet.
but all that data should be pasted in a row, (in sheet2) columns A, B, C, D, E, F and on the next empty row.



Manage to find someone online trying to accomplish something similar in year 2004 and i try to follow the code but it
get a run-time error " Run-Time Error '1004': Application-Defined or Object-Defined error " and no follow-up if the code is working.

Can someone help to advice? Thanks

Sub Get_Data()

    Dim lastrowSheet2 As Long, lastrow As Long
    Dim arr1, arr2, i As Integer
    With Worksheets("Sheet2")
        lastrowSheet2 = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With
    arr1 = Array("B2", "B4", "B6", "D2", "D4", "D6")
    arr2 = Array("A", "B", "C", "D", "E", "F")
    For i = LBound(arr1) To UBound(arr1)
        With Sheets("Sheet1")
             lastrow = Application.Max(3, .Cells(.Rows.Count, Left(arr1(i), 1)).End(xlUp).Row)
             Sheets("Sheet2").Range(arr2(i) & lastrowDB).Resize(lastrow - 2).Value = _
      .Range(.Cells(3, arr1(i)), .Cells(lastrow, arr1(i))).Value
        End With
    Next
    Application.CutCopyMode = False
End Sub

 

[dmt32]

Hi,
quick look at your code, this variable "lastrowDB" has not been declared or intialized. I suspect you need to replace it with
variable "lastrowSheet2" which you have declared & intialized but do not seem to be using.

Hope Helpful

Dave

 

[Trebor76]

Hi Rockey_01,

Try this:

Option Explicit
Sub Macro1()

    Dim lngPasteRow As Long
    Dim varArray1 As Variant, _
        varArray2 As Variant
    Dim intArrayIndex As Integer
    
    On Error Resume Next 'Account for there being no data in 'Sheet2'.
        lngPasteRow = Sheets("Sheet2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    On Error GoTo 0
    
    If lngPasteRow = 0 Then
        lngPasteRow = 2 'Default value if there's no data in 'Sheet2'. Change to suit.
    Else
        lngPasteRow = lngPasteRow + 1
    End If
    
    varArray1 = Array("B2", "B4", "B6", "D2", "D4", "D6")
    varArray2 = Array("A", "B", "C", "D", "E", "F")
    
    Application.ScreenUpdating = False
    
    For intArrayIndex = LBound(varArray1) To UBound(varArray1)
        Sheets("Sheet2").Range(varArray2(intArrayIndex) & lngPasteRow).Value = Sheets("Sheet1").Range(varArray1(intArrayIndex)).Value
    Next intArrayIndex

    Application.ScreenUpdating = True

End Sub

HTH

Robert

 

[Rockey_01]

Hi Trebor76,

This is just wonderful. Is there a way I can clear the data automatically for the next entry as well when I click the submit button? Thanks!!!

 

[Trebor76]

I take it you mean to clear the data from Sheet1 after it gets populated to Sheet2?

If so, this will do the job:

Option Explicit
Sub Macro1()

    Dim lngPasteRow As Long
    Dim varArray1 As Variant, _
        varArray2 As Variant
    Dim intArrayIndex As Integer
    
    On Error Resume Next 'Account for there being no data in 'Sheet2'.
        lngPasteRow = Sheets("Sheet2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    On Error GoTo 0
    
    If lngPasteRow = 0 Then
        lngPasteRow = 2 'Default value if there's no data in 'Sheet2'. Change to suit.
    Else
        lngPasteRow = lngPasteRow + 1
    End If
    
    varArray1 = Array("B2", "B4", "B6", "D2", "D4", "D6")
    varArray2 = Array("A", "B", "C", "D", "E", "F")
    
    Application.ScreenUpdating = False
    
    For intArrayIndex = LBound(varArray1) To UBound(varArray1)
        With Sheets("Sheet1").Range(varArray1(intArrayIndex))
            Sheets("Sheet2").Range(varArray2(intArrayIndex) & lngPasteRow).Value = .Value
            .ClearContents
        End With
    Next intArrayIndex

    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Rockey_01]

Hi Robert,

Thank you so much.

 

[Trebor76]

You're welcome