エクセルVBAマクロについて質問です。お気持ちのみですが、合計200p~差し上げます。

1)のデータから2)のデータ群を作るマクロを作って下さい。

1)samplefile.xls("Sheet1")
fnameA,fnameA,fnameA,fnameB,fnameB,fnameC,fnameC,・・・
lnameA,lnameB,lnameC,lnameD,lnameE,lnameF,lnameG,・・・
s1, s2, s3, s4, s5, s6, s7,・・・
s8, s9, s10, s11, s12, s13, s14,・・・
 ・
 ・
 ・
※"fnameA" ~ "fnameC"として出力したいデータベースが、横に連続表記されたようなイメージです。
※1行目にファイルネームが、2行目はファイルネームに対応する列の名前を記載しています。
※1行目を順に右に読んでいって、ファイルネームが変更されたら次のxlsファイルを生成し、ブランクを発見したら終了、という動作です。

2)出力結果
●出力ファイル
fnameA.xls,fnameB.xls,fnameC.xls,・・・

●fnameA.xlsのSheets"fnameA"の中身
lnameA,lnameB
s1, s2
s8, s9
 ・
 ・
 ・
fnameB.xls,fnameC.xlsも同様

お力添えをよろしくお願い致します。

※類似質問
http://q.hatena.ne.jp/1162474581
ですが、まだファイルの読み書きに慣れていませんので質問させて頂きます。

回答の条件
  • 1人2回まで
  • 登録:2008/12/21 19:14:02
  • 終了:2008/12/22 13:06:55

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/12/21 20:44:30

ポイント200pt

実行するファイルと同じフォルダにファイルを作ります。

すでにファイルがあると保存時に警告が出るので、再度実行する際は

ファイルを削除もしくは退去してから実行してみてください。

Option Explicit

'-----------------------------------------------------------------------------------
Sub makeXLSs()
'-----------------------------------------------------------------------------------
    Dim i As Long
    Dim bookName As String

    Dim dstWB As Workbook
    Dim srcWS As Worksheet
    Dim srcRows As Long
    Dim dstCol As Long
    
    Set srcWS = ThisWorkbook.Worksheets("Sheet1")
    i = 1
    For i = 1 To srcWS.Cells(1, 1).End(xlToRight).Column
'--- ファイルを確認
        If srcWS.Cells(1, i).Value <> bookName Then
'--- データがあったら保存
            If Not dstWB Is Nothing Then
                dstWB.SaveAs ThisWorkbook.Path & "\" & bookName
                dstWB.Close
            End If
            bookName = srcWS.Cells(1, i).Value
            Workbooks.Add
            Set dstWB = ActiveWorkbook
            dstCol = 1
        End If
'--- データを転記
        srcRows = srcWS.Cells(2, i).End(xlDown).Row - 1
        srcWS.Cells(2, i).Resize(srcRows, 1).Copy Destination:=dstWB.Worksheets(1).Cells(1, dstCol)
        dstCol = dstCol + 1
    Next
'--- データがあったら保存
    If Not dstWB Is Nothing Then
        dstWB.SaveAs ThisWorkbook.Path & "\" & bookName
        dstWB.Close
    End If
End Sub
id:ReoReo7

ありがとうございます。所望の動作を得られました!

シート名の変更にも対応して頂き、ありがとうございました。

感謝いたします。

2008/12/22 00:00:09
  • id:ReoReo7
    ●fnameA.xlsのSheets"fnameA"の中身
    ですが、列が1つ足りず

    lnameA,lnameB,lnameC
    s1, s2, s3
    s8, s9, s10
     ・
     ・
     ・
    の間違いでした。失礼しました。

  • id:Mook
    仕様の見落としです。
    シートはファイル名と同じ名前ということでしょうか。

    であれば、
      Workbooks.Add
      Set dstWB = ActiveWorkbook
    のあとに
      dstWB.Worksheets(1).Name = bookName
    を追加してください。

    一つのファイルに複数シートが入るようでしたら、情報が不足していると思いますので、
    補足ください。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません