【質問5】

エクセルのマクロを作って下さい。
私の要望通りのものでしたら、300ポイントを差し上げます。

エクセルファイルのsheet8には、
A列から◎列まで文字が入っている

1行目は、空白セルなし。
2行目は、空白セルなし。
3行目以下空白セルあり。

1行目にフォルダ名
2行目にテキスト名
3行目以降にデータが入力されている。

各列の1行目の文字名のフォルダを作成し、そのフォルダの中に2行目の文字名のテキストファイルを作成。
そのテキストファイルは各列3行目から最終行までが各行を一行として書き込まれている。

例)
A B C ◎
1 イヌ イヌ ネコ サル
2 チワ シバ ミケ ゴリ
3 シロ アカ クロ
4 キ テツ
5 ミミ メ
6 カミ

sheet8が上記のようになっていたら、

フォルダは、「イヌ」「ネコ」「サル」
それぞれのフォルダの中に
イヌ:チワ.txt、シバ.txt
ネコ:ミケ.txt
サル:ゴリ.txt
のテキストファイルができる。
各テキストファイルの中身は、
----
チワ.txt
シロ

ミミ
----
シバ.txt
アカ


カミ
----
ミケ.txt

テツ
----
ゴリ.txt
クロ


----

回答の条件
  • 1人3回まで
  • 登録:2009/03/16 23:53:21
  • 終了:2009/03/18 20:18:29

回答(2件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/03/17 00:15:17

ポイント35pt

コメントを有効にしていただければ、仕様と異なる点は補足します。

'----------------------------------------------------------------------------
Sub pinkoQ5()
'----------------------------------------------------------------------------
' ブックの保存してあるフォルダを基準にその下に1行目のフォルダを作成する
'----------------------------------------------------------------------------

    Worksheet("sheet8").Activate
    
    Dim fso As Object
    Dim lastCol
    Dim lastRow
    
    Dim r As Long, c As Long
    Dim folderPath As String
    
    lastCol = Range("A1").End(xlToRight).Column
    For c = 1 To lastCol
        folderPath = ThisWorkbook.Path & "\" & Cells(1, c).Value
        If fso.FolderExists(folderPath) = False Then
            fso.CreateFolder (folderPath)
        End If
        With fso.CreateTextFile(folderPath & "\" & Cells(2, c).Value)
            lastRow = Cells(Rows.Count, c).End(xlUp).Row
            For r = 3 To r
                .WriteLine Cells(r, c).Value
            Next
        End With
    Next
End Sub
id:pinko_pinpin

コメントを有効にしました。

宜しくお願い致します。

2009/03/17 23:15:49
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912009/03/18 11:02:07

ポイント400pt

上記回答する際、削除した部分に問題あり正常動作しませんね。

失礼しました。

(Set fso = CreateObject("Scripting.FileSystemObject") が必要)


Q4 はそちらのコメントでも書いたように、Sheet6 の I列を読む仕様になっています。

異なる場合は、コメントください。


全部を一括で処理する場合は、pinkoQsAll を実行ください。

不要な部分がある場合は、その部分をコメントアウトして実行してください。

Q5だけは 異色な感じがしたので単独で実行する場合は、 OnlyQ5 を実行ください。

Option Explicit
'-------------------------------------------
'--- マイドキュメントからの相対パス
'-------------------------------------------
Const SRC_CSV_FILE = "\cccc\bbbb.csv"
Const DST_XLS_FILE = "\cccc\aaaa.xls"

'----------------------------------------------------------------------
Sub pinkoQsAll()
'----------------------------------------------------------------------
'// Q1 ~Q5 を一括して処理する関数
'----------------------------------------------------------------------
    Dim WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    
    Dim dstPath As String
    dstPath = WSH.SpecialFolders("MyDocuments") & DST_XLS_FILE
    
    Dim dstWB As Workbook
    Set dstWB = getWB(dstPath)
    
    Dim dataRows As Long

'// Q1 の処理
    dataRows = copyCSV(dstWB, getWB(WSH.SpecialFolders("MyDocuments") & SRC_CSV_FILE))
    If dataRows = 0 Then Exit Sub '// 読み込んだデータがなければ終了

'// Q2 の処理
    dataPrep1 dstWB, dataRows
    
'// Q3 の処理
   dataPrep2 dstWB, dataRows
     
'// Q4 の処理
    setFilterdData dstWB, dataRows
    
'// Q5 の処理
    makeFiles dstWB, "Sheet8"
End Sub

'----------------------------------------------------------------------
Sub OnlyQ5()
'----------------------------------------------------------------------
'// Q5 だけを実行する関数
'----------------------------------------------------------------------
    Dim WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    
    Dim dstPath As String
'// ファイル名は適宜変更ください。
    dstPath = WSH.SpecialFolders("MyDocuments") & "\cccc\aaaa.xls"
       
'// 上書き実行
'    makeFiles getWB(dstPath), "Sheet8", True
'// 追記で実行
    makeFiles getWB(dstPath), "Sheet8", False
End Sub

'----------------------------------------------------------------------
Function copyCSV(dstWB As Workbook, srcWB As Workbook) As Long
'----------------------------------------------------------------------
'// Q1 の処理
'----------------------------------------------------------------------
    If dstWB Is Nothing Or srcWB Is Nothing Then
        MsgBox "ファイルがありません"
        copyCSV = 0
        Exit Function
    End If
    
    Const dstSheetName = "Sheet1"
    
    Dim lastRow As Long
    lastRow = srcWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row

    srcWB.Worksheets(1).Range("A2").Resize(21, lastRow - 1).Copy _
        Destination:=dstWB.Worksheets(dstSheetName).Range("A2").Resize(21, lastRow - 1)
    srcWB.Close
    copyCSV = lastRow
End Function

'----------------------------------------------------------------------
Sub dataPrep1(dstWB As Workbook, dataRows As Long)
'----------------------------------------------------------------------
'// Q2 の処理
'----------------------------------------------------------------------

'// Sheet2 の A3:M3 を データ行数までコピー
    With dstWB.Worksheets("Sheet2")
        .Activate
        Dim r As Long
        For r = 3 To dataRows - 1
            .Range("A3:M3").Copy _
                Destination:=.Range("A1").Offset(r, 0).Resize(1, 13)
        Next
    End With

'// Sheet3 の A3:L3 を データ行数までコピー
    With dstWB.Worksheets("Sheet3")
        .Activate
        For r = 3 To dataRows - 1
            .Range("A3:L3").Copy _
            Destination:=.Range("A1").Offset(r, 0).Resize(1, 12)
        Next
    End With
End Sub

'----------------------------------------------------------------------
Sub dataPrep2(dstWB As Workbook, dataNum As Long)
'----------------------------------------------------------------------
'// Q3 の処理
'----------------------------------------------------------------------
    Dim srcWS As Worksheet
    Set srcWS = dstWB.Worksheets("Sheet5")
    
'// 情報に応じて Sheet5 の データを Sheet4 にコピー
    With dstWB.Worksheets("Sheet4")
        .Activate
        Dim lastRow  As Long
        Dim c As Long
        Dim r As Long
        For c = 2 To dataNum
            lastRow = .Cells(Rows.Count, c).End(xlUp).Row + 1
            Select Case .Cells(2, c).Value
            Case 2
                Debug.Print .Cells(Rows.Count, c).End(xlUp).Address
                srcWS.Range("A10:A20").Copy _
                    Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
            Case 3
                srcWS.Range("B10:B21").Copy _
                    Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
            Case 4
                srcWS.Range("C10:C25").Copy _
                    Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
            End Select
        Next
    End With
End Sub

'----------------------------------------------------------------------
Sub setFilterdData(dstWB As Workbook, dataNum As Long)
'----------------------------------------------------------------------
'// Q4 の処理
'----------------------------------------------------------------------
    Dim srcWS As Worksheet
    Set srcWS = dstWB.Worksheets("Sheet6")

'// Filter を使用するシートをアクティブにしないと正常に処理できない
    srcWS.Activate
    
    Dim c As Long
'// フィルタ処理の結果を反映
'// Sheet6 の M 列でフィルタ⇒I列を Sheet4 にコピー
    With dstWB.Worksheets("Sheet4")
        For c = 2 To dataNum
            srcWS.Rows(13).AutoFilter field:=13, Criteria1:="=" & .Cells(3, c).Value
            srcWS.Range("I1").Offset(1, 0).Select
            srcWS.Range(Selection, Selection.End(xlDown)).Copy _
                Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
            srcWS.Rows(13).AutoFilter field:=13
        Next
    End With
End Sub

'----------------------------------------------------------------------
Sub makeFiles(dstWB As Workbook, sheetName As String, Optional overWrite As Boolean = True)
'----------------------------------------------------------------------
'// Q5 の処理
'----------------------------------------------------------------------
'// 同じファイルがあった場合は、基本的には上書き。
'// 追記にする場合は第三引数にFalseを指定
'----------------------------------------------------------------------
    dstWB.Worksheets(sheetName).Activate
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim lastCol
    Dim lastRow
    
    Dim r As Long, c As Long
    Dim folderPath As String
    
    Dim outFile As Object
    lastCol = Range("A1").End(xlToRight).Column
    For c = 1 To lastCol
        folderPath = dstWB.path & "\" & Cells(1, c).Value
        If fso.FolderExists(folderPath) = False Then
            fso.CreateFolder (folderPath)
        End If
        
        If overWrite = True Then
            Set outFile = fso.CreateTextFile(folderPath & "\" & Cells(2, c).Value, True) '// 上書きモードでファイルを作成
        Else
            Set outFile = fso.OpenTextFile(folderPath & "\" & Cells(2, c).Value, 8) '// 追記モードでファイルを開く
        End If
        With outFile
            lastRow = Cells(Rows.Count, c).End(xlUp).Row
            For r = 3 To r
                .WriteLine Cells(r, c).Value
            Next
        End With
    Next
End Sub

'----------------------------------------------------------------------
' 共通関数:操作対象ファイルがなければ開き、開いていたらそれを使用
'----------------------------------------------------------------------
Function getWB(path As String) As Workbook
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FileExists(path) = False Then
        MsgBox path & "がありません"
        Exit Function
    End If
    
    Dim file As Object
    Set file = fso.GetFile(path)
    
    On Error Resume Next
    Set getWB = Workbooks(file.Name)
    On Error GoTo 0
    
    If getWB Is Nothing Then
        Set getWB = Workbooks.Open(path)
    End If
End Function

ある程度 VBA がわかれば、ファイルパス、シート名 を簡単に修正変更できるように

作成したつもりです。

id:pinko_pinpin

ありがとうございます。

助かりました。

2009/03/18 20:16:06

コメントはまだありません

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

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

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

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