Excel ブックのデータを抽出し、転記する

Excel ブックのデータを抽出し、転記する

Sub 抽出1()
Dim myCon As New ADODB.Connection, myRS As New ADODB.Recordset, FileName As String
Dim myCriArray(2) As String, i As Integer

FileName = ThisWorkbook.Path & "\xls\DataBook.xls"
myCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" & _
           "Data Source=" & FileName

'抽出条件
myCriArray(0) = "担当者 ='星野'"
myCriArray(1) = "受注金額 >= 5000"
myCriArray(2) = "受注日 <= #2004/1/31#"

'Recordset オブジェクトに「伝票一覧」シートの内容を読み込む
myRS.Open "[伝票一覧$]", myCon

For i = 0 To UBound(myCriArray)
  'Filter プロパティを使用して抽出
  myRS.Filter = myCriArray(i)
  'シートごとに抽出内容を転記
  Worksheets(i + 1).Range("A1").CopyFromRecordset myRS
Next

myRS.Close: Set myRS = Nothing
myCon.Close: Set myCon = Nothing

End Sub

実行結果
◆Sheet1

◆Sheet2

◆Sheet3

D列は「Sheet1」以外、書式設定がコピーされないため、シリアル値で表示される。
(この図は書式設定を日付に変更したものである。)
なぜ「Sheet1」の書式が日付に変更されるのかは分からない。