How do i change the vba so it enters new entries in one row

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,352
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have code that copies information to a separate spreadsheet. At the moment, the code just finds the last cell in the relevant rows and pastes the data in the next cell below it. I have data in my spreadsheet up to row 56. The procedure correctly puts the data in row 57 but I need the data to be all on the same line. I have data in first 2 columns but there is nothing in the third column yet. After the copy procedure, the new data in columns A and B is in the right spot but the data for column C is up in row 2. How do I change it so it finds the latest entry and then enters all data on the row below it?

The problem is happening with the document stored in wsTrack.

This is my procedure:

VBA Code:
Sub cmdCopy()
    Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker As String, wsSrc As Worksheet, tblrow As ListRow
    Dim Combo As String, sht As Worksheet, tbl As ListObject
    Dim lastrow As Long, DocYearName As String, Site As String, lr As Long
    Dim RowColor As Long, w As Window, r As Long, HoursRegister As String, ReportTracking As String
        Application.ScreenUpdating = False
    'assign values to variables
    Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
    Set sht = ThisWorkbook.Worksheets("Costing_tool")
    Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    For Each tblrow In tbl.ListRows
        If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
            Exit Sub
        End If
    Next tblrow
    For Each tblrow In tbl.ListRows
        Combo = tblrow.Range.Cells(1, 26).Value
        If Not tblrow.Range(1, 8).Value = "" Then
            worker = tblrow.Range.Cells(1, 8).Value
        Else
            worker = "Not allocated"
        End If
        HoursRegister = tblrow.Range.Cells(1, 38)
        ReportTracking = tblrow.Range.Cells(1, 39)
            Select Case tblrow.Range.Cells(1, 6).Value
                Case "Ang Wes", "Ang Riv", "Yir"
                    DocYearName = tblrow.Range.Cells(1, 37).Value
                Case Else
                    DocYearName = tblrow.Range.Cells(1, 36).Value
            End Select
        If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        If Not isFileOpen(HoursRegister & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Hours Register" & "\" & Site & "\" & HoursRegister & ".xlsm"
        If Not isFileOpen(ReportTracking & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"

        Set wsHours = Workbooks(HoursRegister).Worksheets(worker)
        Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
        Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
        lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
        With wsHours
              'this copies the date column in the tblCosting
            tblrow.Range(, 1).Copy
            'this pastes it into column A of hours register file
            .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
              'this copies the YP name column in the tblCosting
            tblrow.Range(, 4).Copy
            'this pastes it into column B of hours register file
            .Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the YP name column in the tblCosting
            tblrow.Range(, 3).Copy
            'this pastes it into column A of hours register file
            .Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the hours column in the tblCosting
            tblrow.Range(, 9).Copy
            'this pastes it into column A of hours register file
            .Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
            
        End With
        
        With wsTrack
              'this copies the date column in the tblCosting
            tblrow.Range(, 1).Copy
            'this pastes it into column A of hours register file
            .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
              'this copies the YP name column in the tblCosting
            tblrow.Range(, 4).Copy
            'this pastes it into column B of hours register file
            .Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the YP name column in the tblCosting
            tblrow.Range(, 5).Copy
            'this pastes it into column A of hours register file
            .Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
            
        End With
        
        With wsDst
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range.Resize(, 7).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range(, 10).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                
                'Overwrites the numbers pasted to column I with a formula
                .Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                'Overwrites the numbers pasted to column L with a formula
                .Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
                'Adds currency formatting to total ex gst column
                .Columns(8).NumberFormat = "$#,##0.00"
                'Adds Australian date format to date column
                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
    
       '         lr = .Cells(Rows.Count, "F").End(xlUp).Row
        '               For r = 1 To lr
       '                    If .Range("F" & r).Value = "Yiriyirimbang" Then .Range("F" & r).EntireRow.Font.ColorIndex = 7
        '               Next r
                'sort procedure copied from vba
                wsDst.Sort.SortFields.Clear
                wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        With Workbooks(DocYearName).Worksheets(Combo).Sort
                            .SetRange Range("A3:AK" & lr)
                            .header = xlYes
                            .MatchCase = False
                            .Orientation = xlTopToBottom
                            .SortMethod = xlPinYin
                            .Apply
                        End With
        End With
    Next tblrow
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Thanks guys
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Untested, but try changing this part:
tblrow.Range(, 5).Copy 'this pastes it into column A of hours register file .Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
to this:
tblrow.Range(, 5).Copy 'this pastes it into column A of hours register file .Range("A" & Rows.count).End(xlUp).Offset(, 2).PasteSpecial xlPasteFormulasAndNumberFormats
 
Upvote 0
I got help with copying some stuff to a different workbook years ago and this is what part of it it looks like and might help you
VBA Code:
Dim c As Range
    With storetorecordsbutton


Set c = Workbooks("records").Sheets("data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
ThisWorkbook.Activate

c.Value = Sheets("Input").Range("G8").Value 'Transfers date to database column A
c.Offset(0, 1).Value = Sheets("Input").Range("G4").Value 'Transfers Client Name to column B
c.Offset(0, 2).Value = Sheets("Input").Range("G5").Value 'Address to C
c.Offset(0, 3).Value = Sheets("Input").Range("G10").Value 'invoice number to D
c.Offset(0, 4).Value = "Quote" 'quote or tax invoice to E
c.Offset(0, 5).Value = Sheets("Input").Range("AL46").Value 'cost price to F
c.Offset(0, 6).Value = Sheets("Input").Range("AO11").Value 'retail price to G
c.Offset(0, 15).Value = Sheets("Input").Range("G9").Value 'owners name to P
c.Offset(0, 16).Value = Sheets("Input").Range("G11").Value 'who did job to Q

it might point you in the right direction
 
Upvote 0
That put all the entries in column A, one row after the other, This is to do with the post 2
 
Upvote 0
ACtually, it does work thanks, I missed part of the code I needed to change.

Thank you
 
Upvote 0

Forum statistics

Threads
1,214,614
Messages
6,120,519
Members
448,968
Latest member
Ajax40

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top