[[20080711151902]]　『エクセルファイルに他のエクセルファイルのシート』（事務作業が進まない子）　ページの最後に飛ぶ

『エクセルファイルに他のエクセルファイルのシートから目的の行を読み込みたい』（事務作業が進まない子）

 社員からエクセルデータでアンケートをとりました。
 そのファイルの中から項目ごとに回答を取り出して１ファイルにしたいのです。
 今は手作業で１つづつファイルを開いて、3行目のデータを手作業でコピー＆ペーストで取り込んでいます。
 こんなことをしていたら今日中に帰れないよう、誰か助けてぇ～、ください。
 　Excel２００３を使用しています。

 o(*'～'*)o がんばっ♪

 ってだけじゃあ、あんまりなので、、、全てのアンケートは同じフォルダーに集めらてれいますか。
 あと、ひとつのブックにシートはいくつで、どのシートとか決まりはありますか。

 （川野鮎太郎）

 とりあえず同じフォルダの開いたシートの3行めを転記します。
Option Explicit
Sub アンケート転記()
Dim myObj As Object
Dim XlApp As Application
Dim myDir As String
Dim StartPath As String
Dim StartFileName As String
Dim Op_Book As Object
Dim myBook As Object
Dim MyRow As Long
Const CstTitle = "フォルダ内のファイル名一覧取得"
Const CstFld = "\*.xls"
Set myBook = ThisWorkbook
Set XlApp = Application
Set myObj = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 0)
XlApp.DisplayAlerts = False
If myObj Is Nothing Then Exit Sub
    If myObj = "デスクトップ" Then
        StartPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    Else
        StartPath = myObj.Items.Item.Path
    End If
If Right(myDir, 1) <> "\" Then myDir = myDir & "\"
StartFileName = Dir(StartPath & CstFld, vbNormal)
MyRow = 5      ' 先頭を5行目に設定
Do While StartFileName <> ""
    Set Op_Book = Workbooks.Open(StartPath & "\" & StartFileName)
    ' 行を加算
    MyRow = MyRow + 1
    Rows(3).Copy Destination:=myBook.Worksheets("Sheet1").Rows(MyRow)
    Op_Book.Close
    StartFileName = Dir()
Loop
XlApp.DisplayAlerts = True
Set myBook = Nothing
Set XlApp = Nothing
Set myObj = Nothing
End Sub

 （川野鮎太郎）

ありがとうございました。
プログラムはすんなり動きました。
これで、もう怖いものは無いです。

（事務作業が進まない子）

コメント返信：

[ 一覧(最新更新順) ]

[[20080711151902]] 『エクセルファイルに他のエクセルファイルのシート』（事務作業が進まない子） ページの最後に飛ぶ

[[20080711151902]]　『エクセルファイルに他のエクセルファイルのシート』（事務作業が進まない子）　ページの最後に飛ぶ