人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

【質問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
クロ


----


●質問者: pinko_pinpin
●カテゴリ:コンピュータ
✍キーワード:txt アカ イヌ エクセル ゴリ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●35ポイント

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

'----------------------------------------------------------------------------
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
◎質問者からの返答

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

宜しくお願い致します。


2 ● Mook
●400ポイント

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

失礼しました。

(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 がわかれば、ファイルパス、シート名 を簡単に修正変更できるように

作成したつもりです。

◎質問者からの返答

ありがとうございます。

助かりました。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ