Open an Excel file with MS Access VBA and move the data from one sheet to another sheet

Question

I am new to VBA Excel Access. I have created a macro-command button in Access data-based that should open an excel file and move data from sheet1 to sheet2. Now when data moves on to sheet2 it should add a remark in column c as updated. However, in sheet2 there is a data already existing, hence it should paste the data below the existing data in sheet2. Excel sheet1

In this sheet 2 already data is existing. Now my macro should paste the data below the existing data in sheet2

I am getting multiple errors This macro I have created in Access VBA because I already have one macro there to export data from access to excel file. In this below I want my macro to move the data from sheet 1 to sheet2 and in sheet2 it should paste the data below exiting data with status as updated.

Please help.

My Codes: -

Option Compare Database
Option Explicit

Private Sub UpdateXL()

Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim wr As Excel.Worksheet
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim i As Long
Dim lr As Long

Set xl = CreateObject("Excel.Application")

Set wb = xl.Workbooks.Open("C:Destination.xlsm")

Set wr = wb.Worksheets("Sheet1")

Set ws = wb.Worksheets("Sheet2")

 

    'Copies then cuts the data from Sheet1" and paste the same in sheet2
   
    With wr
        'LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        lr = wr.Cells(Rows.Count, 1).End(xlUp).Row + 1
        
        Range("A2:B" & LastRow).Cut ws.Range("A2") 'Cut
        
    End With
    
    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

    With ws
    
        LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
        For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
         .Cells(i, "B") = Trim(.Cells(i, "B"))
            Select Case .Range("B" & i)
                Case "FXV", "FST", "FLB", "FFH", "FFJ"
                    .Range("C" & i) = "Updated"
            End Select
        Next i
    End With
    
    
End Sub

"I am getting multiple errors" which errors and in which line? — Pᴇʜ

vanisk vanisk · Accepted Answer · 2020-09-10T09:10:32

Try this -->

Option Compare Database
Option Explicit

Private Sub UpdateXL()

Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim wr As Excel.Worksheet
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim i As Long
Dim lr As Long

Set xl = CreateObject("Excel.Application")
xl.Visible = True

Set wb = xl.Workbooks.Open("C:DestinationPath.xlsm")

Set wr = Worksheets("Sheet1")

Set ws = Worksheets("Sheet2")

 LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    'Copies then cuts the data from "SampleFile" Sheet1" and paste the same in sheet2
   
    With wr
        'LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row  ' 
        
        lr = wr.Cells(.Rows.Count, 1).End(xlUp).Row
        
        If Not lr = 1 Then .Range("A2:B" & lr).Cut ws.Range("A" & LastRow + 1 & ":" & "B" & LastRow + lr - 1) 'Cut
                
    End With
    

    With ws
        For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
         .Cells(i, "B") = Trim(.Cells(i, "B"))
            Select Case .Range("B" & i)
                Case "FXV", "FST", "FLB", "FFH", "FFJ"
                    .Range("C" & i) = "Updated"
            End Select
        Next i
    End With
End Sub

Sample Screenshot

Open an Excel file with MS Access VBA and move the data from one sheet to another sheet

1 Answers