Transpose not adding to next empty row

[Babynod]

Hi All

i have a simple spreedsheet setup for my daily work priority list.

you enter data on sheet1 (Data Entry) hit submit and it goes to Sheet 2(DataBase)

Private Sub CmbSubmit_Click()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    
    Set srcSht = Worksheets("Data Entry")
    Set destSht = Worksheets("Database")
    With destSht
        Set destRng = .Range("A" & Rows.Count).End(xlUp).Offset(1)
    End With
    
    With srcSht
        Set srcRng = .Range("B1:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
    End With
    
    srcRng.Copy
    destRng.PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    Application.CutCopyMode = False
    
    Call Macro3
    
    Range("B1").Clear
    Range("B3", "B5").Clear

End Sub

this then has a custom sort macro which runs to organise

Sub Macro3()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+p
'
    ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort.SortFields.Add _
        (Range("Table2[Status]"), xlSortOnFontColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(255, 192, 0)
    ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort.SortFields.Add _
        (Range("Table2[Status]"), xlSortOnFontColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(255, 0, 0)
    ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort.SortFields.Add _
        (Range("Table2[Status]"), xlSortOnFontColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(112, 173, 71)
    ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort.SortFields.Add _
        (Range("Table2[Priority]"), xlSortOnFontColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(255, 0, 0)
    ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort.SortFields.Add _
        (Range("Table2[Priority]"), xlSortOnFontColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(255, 192, 0)
    ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort.SortFields.Add _
        (Range("Table2[Priority]"), xlSortOnFontColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(112, 173, 71)
    With ActiveWorkbook.Worksheets("Database").ListObjects("Table2").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

this (i think) is the code that pastes in the next blank row

Sub LaptopRegisterTranspose()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    
    Set srcSht = Worksheets("Data Entry")
    Set destSht = Worksheets("Database")
    With destSht
        Set destRng = .Range("A" & Rows.Count).End(xlUp).Offset(1)
    End With
    
    With srcSht
        Set srcRng = .Range("B1:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
    End With
    
    srcRng.Copy
    destRng.PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    Application.CutCopyMode = False

End Sub

my issue is when i started it was working fine, it would paste to the next empty row in my table. but now its pasting to the next empty row below my table instead.

 

[Alex Blakenburg]

my issue is when i started it was working fine, it would paste to the next empty row in my table. but now its pasting to the next empty row below my table instead.

The xlup method takes you to the bottom of the table not to the last row of the Data if there are any empty rows in the table.

Replace this:

    Set destSht = Worksheets("Database")
    With destSht
        Set destRng = .Range("A" & Rows.Count).End(xlUp).Offset(1)
    End With

With this:

    Set destSht = Worksheets("Database")
    Dim destLastRow As Long
    With destSht
        destLastRow = .ListObjects("Table2").ListColumns("Task").Range.Find( _
                        What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set destRng = .Range("A" & destLastRow).Offset(1)
    End With

You can move the Dim statement to the top where the other Dim statements are (optional)

 

[Babynod]

Champion, i replaced this in both my CmbSubmit_click and my LaptopRegisterTranspose module and it works like a charm

 

[Alex Blakenburg]

Thanks for letting me know. Glad I could help.