エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。

http://hatena88.web.fc2.com/hatena/newpage2.shtml
長いマクロなので、最初に正解された人に300ポイント、2以降の正解者の方にも50ポイント差し上げます。

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

回答の条件
  • 1人2回まで
  • 登録:2006/09/25 09:24:41
  • 終了:2006/09/27 03:48:55

回答(3件)

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982006/09/25 10:14:57

ポイント300pt

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

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

の個所で 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

id:taroemon

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

ちゃんと動きました。

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

2006/09/27 03:45:57
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912006/09/25 10:19:06

ポイント50pt

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

id:taroemon

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

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

2006/09/27 03:46:57
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912006/09/25 10:32:28

ポイント50pt

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

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

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

id:taroemon

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

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

2006/09/27 03:48:15
  • id:Mook
    回答の削除機能があればよいのですが、削除できないため別のtoraemonさんの別の回答にコメントいていました。
    (こちらが終了しましたので、移動しました。)

    上記の回答は質問の前半までしか答えておらず、回答として不完全でした。なのでポイントを辞退したかったのですが、せっかくですから、この場ですこし補足をします。

    複数回実行すると、同じシートの作成でエラーになりますが、
    それを回避するためにあったら一度シートを削除(別の処理でもよい)する方法があります。

    '*1:エラーでプログラムを停止しないコマンド
       On Error Resume Next
    'あってもなくても取りあえずセットしてみる、ないと sWS はNothing
       Set sWS = Worksheets("総ワード")
    '*1:を元に戻す。
       On Error Goto 0
    ' なので、すでにシートがあればNothing ではないので
       If Not sWS Is Nothing Then
          ' *2:シートを削除するときに聞かれるメッセージを無効
          Application.DisplayAlerts = False
    ' あった場合のみシートを削除
          sWS.Delete
          ' *2を元に戻す
          Application.DisplayAlerts = True
       End If
    という感じで処理をしておいてから、シートを作成すると、毎回新しいシートを作成することができます。

    シートがあった場合それを利用したい場合は、Not を消して
       If sWS Is Nothing Then
         Worksheets.Add after:=Worksheets(Worksheets.Count)
         Set sWS = ActiveSheet
         sWS.name = "総ワード"
       End If
    とすれば、ない場合だけシートを作成するという処理になります。

    場合に応じて使い分けると良いと思います。
  • id:taroemon
    ご丁寧なコメントありがとうございます。

    最初にいただいた回答が不完全であっても、こうして完全版をいただけたならそれで結構です。

    実は長いマクロをお願いする時、同じ機能を果たすものが2ついらなくても、せっかく作ってもらったのにポイント少なめというのは個人的に心苦しく思うところでもあったのです。
    再回答分のポイントは日頃たくさん回答をいただいている分のお礼として差し上げました。気持ちよく受け取っておいてください。
    今後ともよろしくお願いします。
  • id:Mook
    誤解されていないとは思いますが、上記コメントはシート作成に関する部分の注釈で、処理の全体ではありません(^^;;。

    下記が一応完成版となります。
    いまさらですが、ご参考までに。

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Option Explicit

    '------------------------------------------------------------
    Sub MakeList()
    '------------------------------------------------------------
    ' シートの作成
      deleteSheet "総ワード"
      deleteSheet "親ワード"
      
      Dim sheetNum As Integer
      sheetNum = Worksheets.Count
      
      Dim sWS As Worksheet, pWS As Worksheet
      Set sWS = makeSheet("総ワード")
      Set pWS = makeSheet("親ワード")
      
      Dim tmpArray As Variant
      Dim name As String
      Dim i As Integer

    ' --- シート名のリストの作成
      For i = 1 To sheetNum
        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
      sWS.Cells(1, "D").Value = ""
      
    ' --- 結果ファイルの作成
      Dim lastLine As Integer
      lastLine = sWS.Range("A65535").End(xlUp).Row
      Dim fso As Object, objFile As Object, objParentFile As Object
      Dim fileNum As Integer, parentWord As String
      parentWord = ""
      fileNum = 1

    ' --- 今回はファイルの出力にFileSystemObject を使用
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set objParentFile = fso.CreateTextFile("D:\000.html")
      
      Do
    ' --- 親ワードの検索
        For i = 2 To lastLine
          If sWS.Cells(i, "D").Value <> "" Then
            parentWord = sWS.Cells(i, "D").Value
      ' -- 出力ファイルの作成
            Set objFile = fso.CreateTextFile("D:\zzz-" & Right("000" & fileNum, 3) & ".html")
            pWS.Cells(fileNum, "A").Value = parentWord
            pWS.Cells(fileNum, "B").Value = "zzz-" & Right("000" & fileNum, 3)
            objParentFile.WriteLine "①" & parentWord & "②" & "zzz-" & Right("000" & fileNum, 3) & "③"
            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 & "③"
            objFile.WriteLine line
            sWS.Cells(i, "D").Value = ""
          End If
        Next
        parentWord = ""
        objFile.Close
      Loop While True
      objParentFile.Close
    End Sub

    '------------------------------------------------------------
    Sub deleteSheet(sheetName As String)
    '------------------------------------------------------------
      Dim ws As Worksheet
      On Error Resume Next  ' --- エラー停止を回避
      Set ws = Worksheets(sheetName)
      On Error GoTo 0

    ' --- すでにシートがあれば削除
      If Not ws Is Nothing Then
        Application.DisplayAlerts = False ' --- エラー表示を回避
        ws.Delete
        Application.DisplayAlerts = True
      End If
    End Sub

    '------------------------------------------------------------
    Function makeSheet(sheetName As String) As Worksheet
    '------------------------------------------------------------
    ' --- 一応削除
      deleteSheet (sheetName)
    ' --- 最後にシートを作成
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      Set makeSheet = ActiveSheet
      makeSheet.name = sheetName
    End Function
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  • id:Mook
    P.S.
    インデントのために、上記のコメントは全角スペースを使用しています。
    実行する際には全角スペース「 」を半角スペース2個「 」で置換して、ご使用ください。

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

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

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

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