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

エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。
http://hatena88.web.fc2.com/hatena/newpage2.shtml
長いマクロなので、最初に正解された人に300ポイント、2以降の正解者の方にも50ポイント差し上げます。

なお、現在勉強中ですので、下記の質問の回答者4の方のような解説を付け加えてください。よろしくお願いします。
http://q.hatena.ne.jp/1158311664

●質問者: taroemon
●カテゴリ:コンピュータ
✍キーワード:VBA エクセル ポイント マクロ 勉強
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● きゃづみぃ
●300ポイント

ファイル名の名前が 名前だけとなっていので、親ワードにしてみました。

以下の 'ファイル名をセット

の個所で b というのを "名前" にすれば 固定の名前になります。

Sub Macro1()

'

' Macro1 Macro

'

' Keyboard Shortcut: Ctrl+q

'

'最後にシートを追加します。

Sheets.Add After:=Sheets(Sheets.Count)

'名前を"総ワード"にします。既に"総ワード"という名前があったら、エラーとなります。

Sheets(Sheets.Count).Name = "総ワード"

'ファイルの連番の初期化

e = 1


'シート数分-1(総ワードは 処理しない)処理する。

For i = 1 To Sheets.Count - 1

'シート名を セルに転記

Sheets(Sheets.Count).Range("A" & i) = Sheets(i).Name

'B列の書式を文字列にする。

Sheets(Sheets.Count).Range("B" & i).NumberFormatLocal = "@"

'3桁の数字をセット

Sheets(Sheets.Count).Range("B" & i) = Right(CStr(1000 + i), 3)

'最初の1列目は ファイルに保存しないようだから 2行目から

If i >= 2 Then

'追加したものの総ワードを取り出す。

b = Sheets(Sheets.Count).Range("A" & i)

b = Left(b, InStr(b, " ") - 1)

'出力フラグのクリア

f = 0 '出力していません。

For a = 2 To i - 1

'既に出力したものの総ワードを取り出す。

c = Sheets(Sheets.Count).Range("A" & a)

c = Left(c, InStr(c, " ") - 1)

'同じ親ワードの場合、その総ワードのファイルに出力する。

If b = c Then

Open Sheets(Sheets.Count).Range("C" & a) For Append As #1

Print #1, "?" & Sheets(Sheets.Count).Range("A" & i) & "?" & Sheets(Sheets.Count).Range("B" & i) & "?"

' 他のモードで開く前に、このファイルを一度閉じます。

Close #1

f = 1 '出力しました。

End If



Next a

'出力していなかったら新規で出力

If f = 0 Then

'ファイル名をセット

Sheets(Sheets.Count).Range("C" & i) = "D:\" & Right(CStr(1000 + e), 3) & b & ".html"

e = e + 1

Open Sheets(Sheets.Count).Range("C" & i) For Append As #1

Print #1, "?" & Sheets(Sheets.Count).Range("A" & i) & "?" & Sheets(Sheets.Count).Range("B" & i) & "?"

' 他のモードで開く前に、このファイルを一度閉じます。

Close #1

End If


End If

Next i

'ワークで用いたC列を削除する。

Columns("C:C").Delete Shift:=xlToLeft


End Sub

◎質問者からの返答

いつもご回答ありがとうございました。

ちゃんと動きました。

今後メインテナンスとして、再質問する可能性もありますので、その節はよろしくお願いします。


2 ● Mook
●50ポイント

taknt さん、はやい・・・。

Sub MakeList()

' シートの作成

      Dim sWS As Worksheet
      On Error Resume Next
      Set sWS = Worksheets("総ワード")
      If sWS Is Nothing Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            Set sWS = ActiveSheet
            sWS.name = "総ワード"
      Else
            sWS.Range("A1:D1000").Clear
      End If
      Dim tmpArray As Variant
      Dim name As String

' リストの作成
      For i = 1 To Worksheets.Count - 1
            name = Worksheets(i).name
            sWS.Cells(i, "A").Value = name
            sWS.Cells(i, "B").Value = "'" & Right("000" & i, 3)
            tmpArray = Split(name, " ")
            sWS.Cells(i, "D").Value = tmpArray(0)
      Next
      
' 結果ファイルの作成
      Dim lastLine As Integer
      lastLine = sWS.Range("A65535").End(xlUp).Row
      Dim fso As Object
      Dim fl As Object
      Dim fileNum As Integer
      Dim parentWord As String
      parentWord = ""
      fileNum = 1
      sWS.Cells(1, "D").Value = 0
      Set fso = CreateObject("Scripting.FileSystemObject")
      Do
            For i = 2 To lastLine
                  If Cells(i, "D").Value <> "" Then
                        parentWord = Cells(i, "D").Value
                        Set fl = fso.CreateTextFile("D:\zzz-" & Right("000" & fileNum, 3) & ".html")
                        fileNum = fileNum + 1
                        Exit For
                  End If
            Next
            If parentWord = "" Then
                  Exit Do
            End If
            Dim line As String
            For i = 2 To lastLine
                  If sWS.Cells(i, "D").Value = parentWord Then
                        line = "?" & sWS.Cells(i, "A").Value & "?" & sWS.Cells(i, "B").Value & "?"
                        Debug.Print line
                        fl.WriteLine line
                        Cells(i, "D").Value = ""
                  End If
            Next
            fl.Close
            parentWord = ""
      Loop While True
End Sub

◎質問者からの返答

いつもご回答ありがとうございます。

こちらも使わせていただきます。メインテナンスの際、再質問させていただくこともありますが、その節はよろしくお願いします。


3 ● Mook
●50ポイント

先の回答はポイント不要です(時間をあせり十分コメントできなかったので)

コメントの追加とワークシート作成部分を書き直しました。

Sub MakeList()
' シートの作成
      Dim sWS As Worksheet
      On Error Resume Next
      Set sWS = Worksheets("総ワード")
' すでにシートがあれば削除
      If Not sWS Is Nothing Then
            Application.DisplayAlerts = False
            sWS.Delete
            Application.DisplayAlerts = True
      End If

' 最後にシートを作成
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      Set sWS = ActiveSheet
      sWS.name = "総ワード"
      On Error GoTo 0
      
      Dim tmpArray As Variant
      Dim name As String
' シート名のリストの作成
      For i = 1 To Worksheets.Count - 1
            name = Worksheets(i).name
            sWS.Cells(i, "A").Value = name
            sWS.Cells(i, "B").Value = "'" & Right("000" & i, 3)
' スペースで区切られた先頭語をD列に記載(作業用)
            tmpArray = Split(name, " ")
            sWS.Cells(i, "D").Value = tmpArray(0)
      Next
      
' 結果ファイルの作成
      Dim lastLine As Integer
      lastLine = sWS.Range("A65535").End(xlUp).Row
      Dim fso As Object
      Dim fl As Object
      Dim fileNum As Integer
      Dim parentWord As String
      parentWord = ""
      fileNum = 1
      sWS.Cells(1, "D").Value = 0
'--
' 今回はファイルの出力にFileSystemObject を使用
      Set fso = CreateObject("Scripting.FileSystemObject")
'--
      Do
' 親ワードの検索
            For i = 2 To lastLine
                  If Cells(i, "D").Value <> "" Then
                        parentWord = Cells(i, "D").Value
' -- 出力ファイルの作成
                        Set fl = fso.CreateTextFile("D:\zzz-" & Right("000" & fileNum, 3) & ".html")
                        fileNum = fileNum + 1
                        Exit For
                  End If
            Next
' 該当がなければ終了
            If parentWord = "" Then
                  Exit Do
            End If
            Dim line As String
' ファイルへの出力
            For i = 2 To lastLine
                  If sWS.Cells(i, "D").Value = parentWord Then
                        line = "?" & sWS.Cells(i, "A").Value & "?" & sWS.Cells(i, "B").Value & "?"
' -- 結果の出力
                        fl.WriteLine line
                        Cells(i, "D").Value = ""
                  End If
            Next
' -- ファイルのクローズ
            fl.Close
            parentWord = ""
      Loop While True
End Sub

◎質問者からの返答

ご丁寧にありがとうございます。

takntさんはよほど早かったのでしょうね。いつものお礼もかねてこちらにもポイント付けておきます。またよろしくお願いします。

関連質問


●質問をもっと探す●



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