こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセルVBAに関しての質問です。

エクセルVBAに関しての質問です。

同じフォルダ内に同形式のエクセルファイルが複数あります。そのファイルの特定のシートの中の特定の列のみをコピーして並べたいと思っています。

(1)フォルダはUSBに入れて使ったり、複数のパソコンの中で使われるので特定の場所にあるとは限りません。
(2)フォルダ名はその年度に応じて変更されます。「2009」、「2010」・・・といった具合です。
(3)フォルダ内のファイル数は常に3つで、「記録集計第1期」「記録集計第2期」「記録集計第3期」と名前を付けています。
(4)3つのファイル全てに「結果」という名前のシートがあり、そのシートのC4~AU37までのセルをコピーしたいです。
(5)C4~AU37までのセルには数値では無く、IF関数を使用して出された「◎」「◯」「△」等の文字列が入っています。
(6)コピーしたセルを「記録集計第3期」ファイルの中の「年度末結果」というシートのC2以降に並べてコピーしたいです。
「記録集計第1期」のC4~AU37を「年度末結果」のC2~AU35へ
「記録集計第2期」のC4~AU37を「年度末結果」のAV2~CN35へ
「記録集計第3期」のC4~AU37を「年度末結果」のCO2~EG35へ
といった具合です。
(7)作業手順としては、「記録集計第3期」のファイルを開き、その中の「年度末結果」のシートにボタンを作って上記のVBAを動かせたらと思っています。
(8)「記録集計第1期」「記録集計第2期」のファイルは開かずにデータをコピーしたいです。

勝手なお願いで申し訳ございませんが、
お時間がございましたら、よろしくお願いいたします。

投稿日時 - 2010-03-08 00:00:57

QNo.5733906

困ってます

質問者が選んだベストアンサー

こんにちは。

あと一息ですね。

A列B列が消えてしまう件ですが、
  ThisWorkbook.Worksheets("年度末結果").Cells.Clear
の行で、「年度末結果」シート上のセルを最初に全てクリアしています。

ここを消すか、先頭に'を付けてコメントにすれば大丈夫です。

もし、ある特定のセルをクリアしたければ、
  ThisWorkbook.Worksheets("年度末結果").Range("C2:F9").Clear
にすれば良いです。
列クリアなら
  ThisWorkbook.Worksheets("年度末結果").Columns("C:F").Clear
などにしてください。

投稿日時 - 2010-03-09 12:28:15

お礼

何から何まで本当にありがとうございました。

完璧です!!
すごいです!!

これをきっかけにVBAを勉強してみたくなりました。
色々とお世話になりました。
ありがとうございました。

投稿日時 - 2010-03-09 23:11:00

このQ&Aは役に立ちましたか?

4人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.3

#1、#2です。

大事なことを忘れていました。
私のコードはエクセル2003以前を対象とした作りになっています。

もし、エクセル2007を使っているのであれば、
ファイルの拡張子が[.xls]ではなく[.xlsx]になっていますので、

   myWbName = "記録集計第" & i & "期.xls"

   myWbName = "記録集計第" & i & "期.xlsx"
に変更してください。

投稿日時 - 2010-03-08 19:31:16

補足

ka_na_deさん、すみません。

実際にやってみたのですが、
コピー先のシート『年度末結果』のC2以降へのコピーは完璧だったのですが、
元々入っていたA列とB列の文字が全て消えてしまっていました。

解決できますでしょうか?
甘えてばかりですみません。

お時間がございましたら、教えてくださいませ。

追伸:この文章をお礼のところに書き加えたかったのですが、
補足入力の所で書かせて頂きました。

投稿日時 - 2010-03-09 00:11:03

お礼

はじめまして、ka_na_deさん。

何度も御丁寧に教えて頂き、本当にありがとうございます。

同じような例が無いかと検索ばかりしていたのですが、
やはり、そう簡単には解決法も見つからず、
あきらめかけていましたが、
こんなに親切に教えて頂けて、本当に本当に感謝しております。

早速、明日にでもチャレンジしてみたいと思います。
ありがとうございました。

投稿日時 - 2010-03-08 23:50:22

ANo.2

#1です。

不具合がありましたので修正します。
<不具合内容>
 例えば、「2009」のフォルダーの中の「記録集計第3期」にて
 年度末結果を出力しようとした際、「2008」のフォルダーの
 中の「記録集計第1期」や「記録集計第2期」が既に開いていた場合、
 「2009」ではなく「2008」のファイルの値をコピーしてしまう。
<変更点>
 「記録集計第1期」や「記録集計第2期」が開いている場合は、
  一旦閉じてから再実行するように警告を出すようにしました。

Sub Test2()
  Dim i As Long
  Dim flg As Boolean
  Dim myWb As Workbook
  Dim myWbName As String
  
  Application.ScreenUpdating = False
  
  ChDrive ThisWorkbook.Path
  ChDir ThisWorkbook.Path
  
  ThisWorkbook.Worksheets("年度末結果").Cells.Clear
  
  For i = 1 To 3
    flg = False
    myWbName = "記録集計第" & i & "期.xls"
    If myWbName <> ThisWorkbook.Name Then
      For Each myWb In Workbooks
        If myWb.Name = myWbName Then flg = True
      Next myWb
      If flg = False Then
        Workbooks.Open Filename:=myWbName
      Else
        Workbooks(myWbName).Activate
        MsgBox myWbName & "を閉じてから再実行してください。"
        Exit Sub
      End If
    End If
    Worksheets("結果").Range("C4:AU37").Copy
    ThisWorkbook.Worksheets("年度末結果").Range("C2").Offset(, 45 * (i - 1)).PasteSpecial Paste:=xlPasteValues
    If myWbName <> ThisWorkbook.Name Then
      Application.DisplayAlerts = False
      Workbooks(myWbName).Close SaveChanges:=False
      Application.DisplayAlerts = True
    End If
  Next i
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

投稿日時 - 2010-03-08 19:19:09

ANo.1

こんばんは。

一例です。

<注意>
・ファイルを開いてから処理してます。
 VBAで開いたものは閉じて終了します。
・コピーの際は、値のみ貼り付けしてます。


Sub Test()
  Dim i As Long
  Dim flg As Boolean
  Dim myWb As Workbook
  Dim myWbName As String
  
  Application.ScreenUpdating = False
  
  ChDrive ThisWorkbook.Path
  ChDir ThisWorkbook.Path
  
  ThisWorkbook.Worksheets("年度末結果").Cells.Clear
  
  For i = 1 To 3
    flg = False
    myWbName = "記録集計第" & i & "期.xls"
    For Each myWb In Workbooks
      If myWb.Name = myWbName Then flg = True
    Next myWb
    If flg = False Then
      Workbooks.Open Filename:=myWbName
    Else
      Workbooks(myWbName).Activate
    End If

    Worksheets("結果").Range("C4:AU37").Copy
    ThisWorkbook.Worksheets("年度末結果").Range("C2").Offset(, 45 * (i - 1)).PasteSpecial Paste:=xlPasteValues
    
    If myWbName <> ThisWorkbook.Name And flg = False Then
      Application.DisplayAlerts = False
      Workbooks(myWbName).Close SaveChanges:=False
      Application.DisplayAlerts = True
    End If
  Next i
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

投稿日時 - 2010-03-08 01:26:38

あなたにオススメの質問