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

締切り済みの質問

【VBA】条件分岐について

当方Excel2003です。
○フォルダ内に入力用のブック(複数)とまとめ用ブック(一つ)が存在し
○すべてのブックにはシートが一つしかなく、タイトル行の位置はまとめブック含めすべて同じ構成である
○入力用ブックのシート名は「入力」、まとめ用ブックのシート名は「まとめ」である
前提で、入力用ブックのデータ入力域をまとめ用ブックに順次コピーをしようと作成中のものですが、
入力用のファイルにデータがきちんと入力域(B7~T7、以降B8~T8…と続きます)に入っているファイルでは問題ありませんが、
データの入力がなくタイトル行のみしかないファイルの場合、タイトル行を最終行と認識し、タイトル行を張り付けてしまいます。

上記のケースの場合、
Select Case ~End Selectの間に、さらに条件(データがなければ、あるいはタイトル行のみの場合はなにもせず次のファイルへ…)を足すのを考えたのですがどういうふうに変更したら良いのか
どなたかご教示いただければ幸いです。
よろしくお願いいたします。

ちなみにA列は6行目までタイトル行で、A7から下に1,2,3…と番号を入力していますが、コピーの対象範囲外としています。

Sub 連続貼り付け()
Dim sFile As String
Dim c As Range
Dim myPAth As String

Application.ScreenUpdating = False

sFile = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)

myPAth = ThisWorkbook.Path

Do While 0 < Len(sFile)
     With ThisWorkbook.Worksheets("まとめ")
      Set c = .Range("B" & .Rows.Count).End(xlUp).Offset(1)
     End With

    Select Case sFile
       Case ThisWorkbook.Name:
       Case Else
         With Workbooks.Open(Filename:=myPAth & "\" & sFile, ReadOnly:=True)
             With .Worksheets(入力)
                .Range("B7", .Range("T" & .Rows.Count).End(xlUp)).Copy
                    c.PasteSpecial xlPasteValues
             End With
            .Close SaveChanges:=False
         End With

     End Select

     sFile = Dir()
     Set c = Nothing
  Loop

  Application.ScreenUpdating = True

  End Sub

投稿日時 - 2011-09-07 00:22:42

QNo.6994509

困ってます

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

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

回答(1)

ANo.1

入力シートの最下行>タイトル行ならコピーする,というだけのことで。

作成例:

sub macro1()
 dim myFile as string
 dim myPath as string
 dim c as range
 dim r as long

 mypath = thisworkbook.path & "\"
 myfile = dir(mypath & "*.xls")

 do until myfile = ""
  set c = thisworkbook.worksheets("まとめ").range("B65536").end(xlup).offset(1)
  if myfile <> thisworkbook.name then
   with workbooks.open(filename:=mypath & myfile, readonly:=true)
    r = .worksheets("入力").range("B65536").row
    if r > 6 then
     .worksheets("入力").range("B7:T" & r).copy destination:=c
    end if
    .close savechanges:=false
   end with
  end if
  myfile = dir()
 loop
end sub

投稿日時 - 2011-09-07 00:41:49

あなたにオススメの質問