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

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:

Code:

---

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

---

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?

Hi Vbfbryce,

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

Ok, maybe something like this:

Code:

---

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

---

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.

put this:

Code:

---

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."

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

Attachment 122419

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. :wave:

Different approach, push the junk out of the way.

Code:

---

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

---

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

Code:

---

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:

Code:

---

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).