Format Problems using Copy/Paste with QueryTable

[Hudel]

The following code is part of an Excel 2000 VBA module.

The routine Copy_And_Query is called to copy the format template in the Range(“A1:AH50â€)

The Cell(“C61:Hxx) values are magically obtained from the Query function where xx is = RecordCount + 60 of the SQL selection.

All of this works great except for the fact that Row 61 always loses the format properties obtained from Row11, while Rows 62 through 100 remain like rows 12 through 50 regardless of the Row count returned from the SQL selection.

Queue Paso????

Regards,
Hudel
(e-mail address removed)

Thanks you much if you have any understanding of this.


Sub Copy_And_Query()

Dim lCnt as Long
Dim xSheet as Excel.WorkSheet
Dim xBook as Excel.WorkBook
Dim sSql as String
Dim sCopyTo as String
Dim sCopyFrom as String

Set xBook = ActiveWorkBook
Set xSheet = .Sheets(“Reportâ€)

sCopyTo = "A51"
sCopyFrom = "A1:AH50"

With xSheet
..Range(sRefer).Copy
..Range(sCopyTo).PasteSpecial xlPasteAll
End With ‘xSheet

SSql = “Select Col3, Col4, Col5, Col6, Col7, Col8 “ _
& “From My_Table “ _
& “Where Col1=’Y’ and Col2>10â€

LCnt = Query_Run(xSheet, sSql, “C11â€)

End Sub

Function Query_Run _
(xSheet As Excel.Worksheet, _
sSql As String, _
sRange As String) _
As Long
Dim rsQuery As ADODB.Recordset
Dim qt As QueryTable

On Error GoTo Query_Run_Error

With xSheet

Set rsQuery = Get_Rs(sSql, Query_Run) ‘Get AdoDB RecortSet _
where Query_Run is set to the Record Count

Set qt = .QueryTables.Add(rsQuery, .Range(sRange))

With qt
..Name = "PathWAI Import"
..FieldNames = False
..RowNumbers = False
..FillAdjacentFormulas = False
..PreserveFormatting = True
..RefreshOnFileOpen = False
..BackgroundQuery = True
..RefreshStyle = xlOverwriteCells
..SavePassword = False
..SaveData = True
..AdjustColumnWidth = False
..RefreshPeriod = 0
..WebFormatting = xlWebFormattingAll
..WebPreFormattedTextToColumns = True
..WebConsecutiveDelimitersAsOne = True
..WebSingleBlockTextImport = False
..WebDisableDateRecognition = False
..Refresh BackgroundQuery:=False
End With 'qt
End With
Exit Function

Query_Run_Error:
vX = Err.Description
Resume Next
End Function