[RESOLVED] Shift Excel Cell after executing a macro second time

[LearningMacro]

Hello All,

I've written a (below)macro that pulls data from the sql server 2008 r2. My issue is when the user runs the macro for first time by entering Jobnumber (say J0001) excel puts data on the spreadsheet starting from cell "A1" which is fine. The issue here is, when the user runs the macro for the second time by enterinfg the jobnumber (say J0002), excel puts the data from J0002 on cell "A1" and shifts the cells for J0001(first job) to cell "F" instead of moving down. How can I shift the previous entry down in the spreadsheet with the latest entry on top?

Here is my macro and attachment:

Sub Task()

Dim sqlstring As String
Dim connstring As String
Dim Strcode As String
Strcode = Trim(InputBox("Please enter a Job #", "Task history"))
sqlstring = "select distinct m.JobNumber , cast(m.ExpectedDate as DATE) 'Ship Date' ,m.CustLongName 'Customer' & _
             " from ArchiveJobHeader m  left join AuxiliaryInfoFile af (nolock) on af.jobnumber=m.jobnumber & _
             " where m.JobNumber = '" & Trim(Strcode) & "'" & _
             " order by 'Resulttime'"
connstring = "ODBC;DSN=SQLDSN;UID=test;PWD=test123"
 Dim thisQT As QueryTable
 Set thisQT = ActiveSheet.QueryTables.Add(Connection:=connstring, Destination:=Range("a1", "a1000"))
 thisQT.BackgroundQuery = False
 thisQT.Sql = sqlstring
thisQT.Refresh
End Sub

[vbfbryce]

There's probably a better approach than this, but would it be acceptable to move the existing table "out of the way" first, drop the new one into A1 (etc.), then move the previous one to the next available row below it?

[LearningMacro]

Hi Vbfbryce,

Your approach will also work for me. Please help with this. Thanks.

[vbfbryce]

Ok, maybe something like this:

Sub moveData()
    Dim ws As Worksheet
    Dim nRows As Integer
    Dim rngCopy As Range
    Dim pasteRow As Integer
    
    Set ws = ActiveSheet
    nRows = ws.Range("a" & Rows.Count).End(xlUp).Row - 1    'how many rows are in existing table
    Set rngCopy = ws.Range("a2:e" & nRows + 1)              'range of existing data to copy
    rngCopy.Copy
    ws.Range("a1000").PasteSpecial                          'paste to A1000
    Application.CutCopyMode = False
    rngCopy.Clear                                           'clear original table
    
    'bring in new query table, destination cell A1 **********
    '
    '********************************************************
        
    pasteRow = ws.Range("a999").End(xlUp).Row + 1           'find first blank row after new table is brought in
    ws.Range("a1000:e" & 1000 + nRows - 1).Copy             'copy moved dats
    ws.Range("a" & pasteRow).PasteSpecial
    Application.CutCopyMode = False
    ws.Range("a1000:e" & 1000 + nRows - 1).Clear            'clear moved data
    
    Set ws = Nothing
End Sub

[LearningMacro]

Thank you for your response. Can you please help me integrate the code you suggested in my original macro? I'm new to macros. Thanks again.

[vbfbryce]

put this:

Call task

where I say "bring in new query table."

The first time, you'd run your sub. The second time, you'd run my sub, which would call yours "in the middle."

[LearningMacro]

Hi vbfbryce,

I appreciate your response. I tried calling the sub as you suggested but it still moved existing data to the right. Attached is the screenshot. Please have a look at it.

Thanks

[TnTinMN]

Edit: Do not use this as I neglected to test it sufficiently. If the returned query results exceed the open space, it will push to the right.

I'll leave it here in case some finds something in it useful.

-------------------
My turn.

Different approach, push the junk out of the way.

Sub test()
   Dim ws As Worksheet
   Set ws = ActiveSheet

   Dim qt As QueryTable
   Set qt = GetQueryTable(ws.Range("a1"))
   If Not (qt Is Nothing) Then
      Dim rows As Long
      rows = qt.ResultRange.rows.CountLarge + 1
      ws.rows(qt.ResultRange.row).Resize(rows).Insert Excel.xlShiftDown, Excel.xlFormatFromLeftOrAbove
   End If
   Call Task
End Sub

Public Function GetQueryTable(rng As Excel.Range) As QueryTable
   Dim qt As QueryTable
   Dim checkRow As Excel.Range
   Set checkRow = rng.Worksheet.rows(rng.row)
   For Each qt In rng.Worksheet.QueryTables
      If Not (Application.Intersect(qt.ResultRange, checkRow) Is Nothing) Then
         'range contains QueryTable
         Set GetQueryTable = qt
         Exit For
      End If
   Next
End Function

[TnTinMN]

OK, I think I found a solution. It is similar to the post above, but the QueryTable is created created on a temporary WorkSheet.

Sub Test2()
   Dim currentWS As Excel.Worksheet
   Set currentWS = ActiveSheet
   
   Application.ScreenUpdating = False
   
   ' add a temporary worksheet
   Dim scratch As Excel.Worksheet
   Set scratch = ActiveWorkbook.Worksheets.Add(Type:=Excel.XlSheetType.xlWorksheet, _
                                               After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
   
   Dim rng As Excel.Range
   Set rng = scratch.Range("A1")
   Call Task(rng)

   Dim qt As QueryTable
   Set qt = GetQueryTable(rng)
   If Not (qt Is Nothing) Then
      Dim rows As Long
      rows = qt.ResultRange.rows.CountLarge + 1
      currentWS.rows(1).Resize(rows).Insert Excel.xlShiftDown, Excel.xlFormatFromLeftOrAbove
'      Application.CopyObjectsWithCells = True
      qt.ResultRange.Copy ' Cut fails on Paste
      currentWS.Range("a1").PasteSpecial xlPasteColumnWidths
      currentWS.Range("a1").PasteSpecial xlPasteAll
      qt.Delete
   End If
                                               
   Application.DisplayAlerts = False
   scratch.Delete ' delete temp WS
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

Public Function GetQueryTable(rng As Excel.Range) As QueryTable
   Dim qt As QueryTable
   Dim checkRow As Excel.Range
   Set checkRow = rng.Worksheet.rows(rng.row)
   For Each qt In rng.Worksheet.QueryTables
      If Not (Application.Intersect(qt.ResultRange, checkRow) Is Nothing) Then
         'range contains QueryTable
         Set GetQueryTable = qt
         Exit For
      End If
   Next
End Function

This code would require you to modify your Task method as follows:

Sub Task(rng As Excel.Range)
...
 Set thisQT = rng.WorkSheet.QueryTables.Add(Connection:=connstring, Destination:=rng)
...

I think that if the query result set increases in size that you will have issues with overlap when the queries are updated (Refresh).