| |
▼hana さん：
こんばんは。
>http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=6470;id=excel
>を参考にさせて頂き、作成しました。
>やりたい点は、
>１．インポート先を閉じていて、インポート元となるファイルを開いた状態でインポートしたい。
> （インポート元にはシートが複数あり、そのときactiveのシートをインポートしたい。）
>２．セルAからVの2行目からのデータをインポートしたい。
> （インポート元、インポート先とも、1行目は列名を表示しているので、2行目から行いたい。）
>３．インポート先のファイルにデータを蓄積していきたい。
３回読み返しましたが、これは、エクスポートということですよね？
>Sub import()
> With ThisWorkbook.ActiveSheet.Range("A:V")
> .Formula = "=if(" & _
> "'C:\インポート元ファイルの場所\[Data.xls]ActiveSheet'!A1=" & _
'このエラーは、ActiveSheetが原因です。こういう記述はできません。
'（ActiveSheetというシート名があるなら話は違ってきますが・・・）
> """"",""""," & _
> "'C:\インポート元ファイルの場所\[Data.xls]ActiveSheet'!A1)"
> .Value = .Value
> End With
>End Sub
で、たぶんリンク貼付では無理だと思いますよ。
もし、もし、上記のようなコードで可能だとしても処理速度は大きくは変わりませんよ。
本当は､両方開いて、値を移す方法が一般的だし、簡単だし、・・・
ですが、
私も初めてだったのでTRYしてみました。
hana さんの仕様では、「アクティブシートのＡ列からＶ列の値を開いていないBOOK2.XLSに追加する」ですが、以下のコードは、Ａ列からＢ列を追加するになっていますので、確認後、変更して下さい。
ADOを使いましたので、参照設定で
「Microsoft ActiveX Data Objects 2.X Library」（私は、2.5でした）を
チェックして下さい。
標準モジュール（Module1）に、
'=====================================================================
Sub main()
Dim sql_str As String
If open_ado("D:\My Documents\ＴＥＳＴエリア\ExportBK.xls") = 0 Then
' 接続処理 ↑ここにエクスポート先ブックをフルネームで指定
sql_str = "[Sheet1$];"
' エクスポート先のシート名の後ろに「$」を付ける
If open_rs(sql_str) = 0 Then 'レコードセットのオープン
With ActiveSheet
Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
' ↑アクティブシートのＡ列の入力範囲を取得
End With
For idx = 1 To rng.Count
If add_rs(rng.Cells(idx).Resize(1, 2)) <> 0 Then
' ↑A列とB列を1行づつ追加 V列までなら2を22に変更
Exit For
End If
Next idx
rs_close 'レコードセットのクローズ
End If
close_ado 'エクスポートブックへの接続解除
Else
MsgBox "接続失敗"
End If
End Sub
標準モジュール（Module2）に、
'================================================================
Public cn As New ADODB.Connection
Public rs As New ADODB.Recordset
'================================================================
Function open_ado(book_fullname As String) As Long
'excelブックに接続
On Error Resume Next
link_opt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & book_fullname & ";" & _
"Extended Properties=Excel 8.0;"
cn.Open link_opt
open_ado = Err.Number
On Error GoTo 0
End Function
'================================================================
Sub close_ado()
'接続解除
On Error Resume Next
cn.Close
On Error GoTo 0
End Sub
'================================================================
Function open_rs(sql_str As String) As Long
'レコードセットのオープン
On Error Resume Next
rs_close
rs.Open sql_str, cn, adOpenStatic, adLockOptimistic
If Err.Number <> 0 Then
MsgBox Error$(Err.Number)
End If
open_rs = Err.Number
On Error GoTo 0
End Function
'=================================================================
Function add_rs(rng As Range) As Long
'データレコードの追加
On Error GoTo err_add_rs
With rs
.AddNew
For idx = 1 To rng.Count
.Fields(idx - 1).Value = rng.Cells(idx).Value
Next idx
.Update
End With
add_rs = 0
ret_add_rs:
On Error GoTo 0
Exit Function
err_add_rs:
MsgBox Error$(Err.Number)
add_rs = Err.Number
Resume ret_add_rs
End Function
'===================================================================
Sub rs_close()
'レコードセットのクローズ
On Error Resume Next
rs.Close
On Error GoTo 0
End Sub
こちらで確認した限りでは、正しく追加できていますが、
確認してみて下さい。
|
|
