ここから質問投稿すると、最大4000ポイント当たる!!!! >>

こんにちは
ExcelのVBAで列のカテゴリ別にテキストへ書き出しをしたいです。
----------------------------------------
A列  B列  C列 D列 E列 ...
KK  123  あ
AA  458  い
AA  457  お
KK  784  か
CC  456  き
KK  785  え
CC  785  く
----------------------------------------
上記のようなシートがあるとして、
A列でカテゴリを分け、B列の重複を削除しシートに書き出されている内容をテキストへ書き出したいです。

書き出し後のイメージ
---------------------------------------
KK  123  あ ...
KK  784  か ...
KK  785  え ...
---------------------------------------
こんなイメージのテキストファイルをKKとAAとCCで3つ作りたいみたいな感じです。

わがままな質問は重々承知ですが、コードを書いていただければと思います><
よろしくお願いいたします。

質問者からの補足コメント

  • ご回答ありがとうございます。
    重複の削除はVBA使わなくてもできるのですが、データを残しておきたいのと、何よりVBAで重複の削除と書き出しを同時にやりたかったのでこの質問でした。

    重複の削除(A列とB列の重複)はExcelでやるとしてカテゴリ別の抽出方法ご存知でしたらご教授願いたいです。

    No.1の回答に寄せられた補足コメントです。 補足日時:2019/09/26 10:48
  • 毎日の作業になるのでVBAで自動化したいのです...
    最終的にやりたいのはカテゴリ別のテキストへの書き出しの自動化ですので
    カテゴリに分けたり、重複削除する手順は省いてもらって構いません。

    もう一度いいます。重要なのはカテゴリ別に複数のテキストへ書き出しです。
    知っているのであればご教授いただれば幸いです。

    No.2の回答に寄せられた補足コメントです。 補足日時:2019/09/26 11:11
  • ご回答ありがとうございます。

    テキストへの書き出し方法はご存知ありませんか?><

    No.3の回答に寄せられた補足コメントです。 補足日時:2019/09/26 11:46
  • 起票した例であげれば
    KK
    CC
    AA
    と3つのファイルをCSV形式で手動で保存しないといけないのが時間効率が悪いので
    一発でテキスト書き出しを行うVBAを使いたいんです。

    エクセルでもできる。当たり前です。業務効率を考慮し、省くべき所を省きたいので聞いています。
    的外れな回答はこれ以上しないでください。
    聞きたいのは”VBAでA列の項目ごとの複数の.txtで書き出す方法”です。
    知っていたらご教授お願いいたします。

    No.4の回答に寄せられた補足コメントです。 補足日時:2019/09/26 12:25
  • ご回答ありがとうございます><
    また、不明点が多く申し訳ございません...
    1.A はい。出力ファイル名はA列の値でよろしくおねがいします。
    2.A A列のファイルに小文字は存在しませんのでこれは想定しなくて大丈夫です。
    3.A 一行目は見出しです。データは二行目からになります。
    4.A 列数はまちまちです。4行になったりするときもあれば、一行にもなりえます。
    5.A tabを一回押すスペースです。

    No.6の回答に寄せられた補足コメントです。 補足日時:2019/09/26 15:45
  • ご回答ありがとうございます...
    B列が重複していたらC列以降はデータは同一です。
    最初の例の書き方が、A列の重複でしかB列の重複はないのにA列の重複なしでB列重複という間違えた書き方になっていました...

    希望は.txtですがCSVファイルでの書き出しができるのならアレンジしようと思い焦っていました。
    データそのものにカンマは含みません。

    No.8の回答に寄せられた補足コメントです。 補足日時:2019/09/26 15:50
  • 詳しく書いていただきありがとうございます><
    質問1
    "保存先"というエクセルファイル名でシート名が"貼り付け"
    の場合、このコード上で変更しないといけない箇所はどこですか?

    質問2
    データの範囲が変数(3列の時もあれば4列の時も存在する場合)もこのコードのままで大丈夫ですか??

    No.9の回答に寄せられた補足コメントです。 補足日時:2019/09/26 16:15
  • >私は、何行あるのですかと聞いたのではありません。
    >何列あるのですかと聞いたのです。
    行ではありませんでしたね。4列にもなりますし、1列の場合もあります。
    最大列数はG列です。A~G列で全列データが有るときもあれば1列しか無い時もあります。
    行数も一定ではありません。100行もあるし、1000行も想定しています。

    >これは、タブ1個と解釈します。
    はい。よろしくおねがいします。

    No.10の回答に寄せられた補足コメントです。 補足日時:2019/09/26 16:33
  • ご回答ありがとうございます。

    ファイル名はA列の値で大丈夫です^^


    No9のコードをつかってみました。

    SSS 456
    AAA 852
    SSS 456
    SSS 963
    AAA 369
    XXX 753
    SSS 951
    XXX 159
    SSS 741
    XXX 654
    AAA 768
    AAA 249
    SSS 367

    上記サンプルで試しましたが、結果がSSS、AAA、XXXのテキストは作成されているのですが
    中身に何も入っていません。
    理想は
    SSS.txtの中身↓
    456
    963
    951
    741
    367

    AAA.txtの中身↓
    852
    369
    768
    249

    XXX.txtの中身↓
    753
    159
    654

    という風に書き出していただきたいのですが、無理でしょうか><

    No.12の回答に寄せられた補足コメントです。 補足日時:2019/09/26 17:38
  • 大変ご丁寧にありがとうございます。

    >これは、どちらが正しいのでしょうか。
    すみません。正しくは
    No12の回答に寄せられた補足コメントでは、B列の値からAA.txtへ出力しています。(A列の値は出力していません)
    こちらが理想です。
    A列を出力せず(テキスト名はA列に)、B列からの出力にしていただきたいです。

    >もし、No12の回答に寄せられた補足コメントが正しい場合は、AA.txtの内容は
    -------------------------------------
    <改行>
    BB<改行>
    --------------------------------
    はい。上記が希望していた出力です。

    よろしくお願いいたします。

    No.14の回答に寄せられた補足コメントです。 補足日時:2019/09/26 19:07

A 回答 (17件中1~10件)

標準モジュールに登録してください。


テキストファイルはこのマクロのあるファイルと同じフォルダの下に作成されます。
--------------------------------------------
Option Explicit

Public Sub カテゴリ別出力()
Dim dict1 As Object '連想配列 キー A列:値 行番号のArrayList(カテゴリ別用)
Dim dicT2 As Object '連想配列 キー A列+B列:値 True (重複チェック用)
Dim aryList As Object
Dim maxrow As Long
Dim wrow As Long
Dim key1 As Variant
Dim key2 As Variant
Set dict1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicT2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
maxrow = Cells(Rows.Count, 1).End(xlUp).Row ' A列最終行を求める
'A+Bの重複データを削除しながら、カテゴリ毎の行番号を登録する
For wrow = 2 To maxrow
key1 = Cells(wrow, "A").Value
key2 = Cells(wrow, "A").Value & "|" & Cells(wrow, "B").Value
If dicT2.Exists(key2) = False Then
'A列+B列で重複がない場合
dicT2(key2) = True
If dict1.Exists(key1) = False Then
'同一カテゴリの1番目
Set aryList = CreateObject("System.Collections.ArrayList")
aryList.Add wrow
dict1.Add key1, aryList
Else
'同一カテゴリの2番目以降
dict1(key1).Add wrow
End If
End If
Next
'カテゴリ毎に全カテゴリを処理する
For Each key1 In dict1
'1カテゴリ分の出力
Call write_text(dict1, key1)
Next
MsgBox ("完了")
End Sub
'1カテゴリ分のテキスト出力
Private Sub write_text(ByVal dict1 As Object, ByVal key1 As Variant)
Dim line As String
Dim i As Long
Dim fname As String
Dim wrow As Long
Dim wcol As Long
Dim maxcol As Long
fname = ThisWorkbook.Path & "\" & key1 & ".txt"
Open fname For Output As #1
'カテゴリに一致する行分の繰り返し
For i = 0 To dict1(key1).Count - 1
'該当行取得
wrow = dict1(key1)(i)
'最大列取得
maxcol = Cells(wrow, Columns.Count).End(xlToLeft).Column
'2列目設定
line = Cells(wrow, 2).Value
'3列目以降
For wcol = 3 To maxcol
line = line & vbTab & Cells(wrow, wcol).Value
Next
Print #1, line
Next
Close #1
End Sub
    • good
    • 0
この回答へのお礼

ありがとうございます!希望通りの動作してくれました。
何から何まで足りない私の要望を聞いてくださいまして本当にありがとうございました。
ベストアンサーについては迷ったんですが、細かくヒアリングしていただいたtatsu99さんに選ばせていただきます。
ありがとうございました。
またよろしくお願いいたします。

お礼日時:2019/09/27 09:19

No13です



>ただ補足の通り、A列の出力は希望していないです><
当初の説明にも書きましたように、不明部分は勝手に空想しています。(大抵は、質問しても明らかにならないことが多いので)
とはいうものの、ご指摘の部分に関しては、ご質問文に明示されているので、その通りになっていると思いますけれど?

「A列がいらない」に変更したいのなら、コピペの際のセル範囲からA列を除いておけばよいだけなのですが、一発では直らないので…
後づけで、効率は悪いですが、ファイル出力の前に、A列を削除する処理を追加することでも結果的には同じになります。
この方法なら、1行の追加しておけばすみます。
 Columns(1).Delete
(わざわざここに書く必要もないでしょうけれど)
    • good
    • 0

No.8です。



うちのはお古なのでこんな感じになっちゃいました。
ただエンコードについてはそちらで適切なのか?と疑問はあるのですが。(何せ苦手で)

Sub megu()
Dim myDic As Object
Dim chList As Object
Dim FSO As Object
Dim rr As Range, rc As Range
Dim F_Path As String, st As String, key
Dim i As Long

Set myDic = CreateObject("Scripting.Dictionary")
Set chList = CreateObject("System.Collections.ArrayList")
Set FSO = CreateObject("Scripting.FileSystemObject")

F_Path = ThisWorkbook.Path & "\" '書き出すパスは、このBookのあるフォルダ

For Each rr In Range("A2", Cells(Rows.Count, 1).End(xlUp))
st = rr.Value & "_" & rr.Offset(, 1).Value
If chList.IndexOf_3(st) < 0 Then
chList.Add (st)

If Not myDic.Exists(rr.Value) Then myDic.Add rr.Value, CreateObject("System.Collections.ArrayList")
Set rc = Range(rr.Offset(, 1), Cells(rr.Row, Columns.Count).End(xlToLeft))

If rc.Column > 1 Then
myDic(rr.Value).Add Join(Application.Index(rc.Value, 1, 0), ",")
Else
myDic(rr.Value).Add rr.Offset(, 1).Value
End If

End If
Next

For Each key In myDic.Keys
With FSO.CreateTextFile(F_Path & key & ".csv")

For i = 0 To myDic(key).Count - 1
.WriteLine myDic(key)(i)
Next
.Close

End With
Next

Set myDic = Nothing
Set chList = Nothing
Set FSO = Nothing
End Sub

もしかしたら無駄骨だったかもねぇ。
    • good
    • 0

No10です。

補足ありがとうございました。
添付図のようなシートの場合、
AA.txtの内容は
2、3行目はB列の値が同じ(空白)
4、5行目はB列の値が同じ(BB)
なので、重複を削除した結果、以下のようになります。
------------------------------------
AA<改行>
AA<tab>BB<改行>
-----------------------------------
となりますが、よろしいでしょうか。
<tab>はタブ1文字、<改行>は、改行コードです。

念のためですが、以下のようにはなりません。
AA<tab><tab><tab><tab><tab><tab><改行>
AA<tab>BB<tab><tab><tab><tab><tab><改行>

更に、(非常に大切なことですが)あなたが最初に提示されたサンプルでは、A列の値をAA.txtへ出力していますが、
No12の回答に寄せられた補足コメントでは、B列の値からAA.txtへ出力しています。(A列の値は出力していません)
これは、どちらが正しいのでしょうか。
もし、No12の回答に寄せられた補足コメントが正しい場合は、AA.txtの内容は
-------------------------------------
<改行>
BB<改行>
--------------------------------
のようになります。
「(Excel)条件別に複数のテキストへ書」の回答画像14
この回答への補足あり
    • good
    • 0

No12です



補足(2019/09/26 17:38)のデータを、A1:B13にセットした状態でテストしてみました。

>中身に何も入っていません。
というようなことはなく、きちんと質問文の本文に記されたような内容で分類された、テキストファイルができていますけれど・・・?
    • good
    • 1
この回答へのお礼

ありがとうございます!標準モジュールで作成したらできました!
ただ補足の通り、A列の出力は希望していないです><
でもとても丁寧に教えていただき本当にありがとうございました。

お礼日時:2019/09/26 19:08

No9です



>質問1
保存ファイル名のことであれば、最低で必要なのは以下の1行です。
 wb.SaveAs Filename:=p & key & ".txt",~~~
のファイル名を指定すれば、そのファイル名で保存されます。(フルパスで指定)

>質問2
説明にも書いた通り、A1セルのCurrentRegionを対象範囲として解釈しています。
https://docs.microsoft.com/ja-jp/office/vba/api/ …

範囲が異なる場合は、最初のほうの範囲取得部の
 Set rng = ws.Cells(1, 1).CurrentRegion
で、セル範囲を好きな範囲に設定すれば、そちらが採用されることになります。
(No9のコードをそのまま使うなら、範囲はA1セルを含んでいる必要があります)
この回答への補足あり
    • good
    • 0

こんにちは!



横からお邪魔します。
A列項目別に別シート表示で良いのですね?

一例です。
元データは「Sheet1」にあるとします。
標準モジュールにしてください。

Sub Sample1()
 Dim myDic As Object
 Dim i As Long, j As Long, k As Long, lastRow As Long
 Dim c As Range, cnt As Long
 Dim sN As String, wS As Worksheet
 Dim myFlg As Boolean
 Dim myKey, myR

  Application.ScreenUpdating = False
   Set myDic = CreateObject("Scripting.Dictionary")

   '//▼シートの整理//
    With Worksheets("Sheet1")
     lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
      myR = Range(.Cells(2, "A"), .Cells(lastRow, "C"))
       For i = 1 To UBound(myR, 1)
        If Not myDic.exists(myR(i, 1)) Then
         myDic.Add myR(i, 1), ""
        End If
       Next i
   myKey = myDic.keys
    For i = 0 To UBound(myKey)
     sN = myKey(i)
      For k = 2 To Worksheets.Count
       If Worksheets(k).Name = sN Then
        myFlg = True
        Exit For
       End If
      Next k
       If myFlg = False Then
        Worksheets.Add after:=Worksheets(i + 1)
        ActiveSheet.Name = sN
       End If
        Worksheets(sN).Move after:=Worksheets(i + 1)
        myFlg = False
    Next i
     Set myDic = Nothing

    '//▼処理//
     cnt = 1
     For k = 2 To Worksheets.Count
      sN = Worksheets(k).Name
      Set wS = Worksheets(sN)
      wS.Cells.ClearContents
       wS.Range("A1:C1").Value = .Range("A1:C1").Value
       For i = 1 To UBound(myR, 1)
        If myR(i, 1) = sN Then
         Set c = wS.Range("B:B").Find(what:=myR(i, 2), LookIn:=xlValues, lookat:=xlWhole)
          If c Is Nothing Then
           cnt = cnt + 1
           wS.Cells(cnt, "A") = sN
           wS.Cells(cnt, "B") = myR(i, 2)
           wS.Cells(cnt, "C") = myR(i, 3)
          Else
           wS.Cells(c.Row, Columns.Count).End(xlToLeft).Offset(, 1) = myR(i, 3)
          End If
        End If
       Next i
      cnt = 1
     Next k
    End With
  Application.ScreenUpdating = True
   MsgBox "完了"
End Sub

こんな感じではどうでしょうか?m(_ _)m
    • good
    • 0
この回答へのお礼

ありがとうございます!今回のご質問はA列項目別に.txtへ書き出しなのです><
tom04さんのコードは趣旨はちがうのですが、とても便利なので別作業で使わせていただきます!!

お礼日時:2019/09/26 17:40

No6です。

補足ありがとうございました。
>4.A 列数はまちまちです。4行になったりするときもあれば、一行にもなりえます。
私は、何行あるのですかと聞いたのではありません。
何列あるのですかと聞いたのです。
提示例では何列まで(例えばJ列等)あるかが不明なのです。
各行によりまちまちかとは、
2行の場合、最大J列
3行の場合、最大X列
のようなケースがありますかという意味です。

5.A tabを一回押すスペースです。
これは、タブ1個と解釈します。
まれに、エディタの設定により、タブキーを1回押すと、スペースが(該当するタブのサイズの位置まで)複数個埋め込まれるものがありますが、
このようなことは期待されていないと解釈します。
これでよろしいでしょうか。
この回答への補足あり
    • good
    • 0

No5です



少し時間があったので、適当に作成してみました。
不明点に関しては、勝手に空想しています。

※ アクティブシートに対象データがあるものと仮定
※ データの範囲は、A1セルのCurrentRegionで取得可能と仮定
※ テキストファイルは、対象データのブックの保存先のフォルダに作成されます

Sub Sample()
Dim wb As Workbook, ws As Worksheet, sh As Worksheet
Dim p As String, n As String, key As String
Dim rng As Range, tr As Range, r As Long

Set ws = ActiveSheet
n = ws.Parent.Name
r = InStr(n, ".")
If r > 1 Then n = Left(n, r - 1)
p = ws.Parent.Path & "\" & n & "_"

Application.ScreenUpdating = False
Set wb = Workbooks.Add
Set sh = ActiveSheet
Set rng = ws.Cells(1, 1).CurrentRegion
rng.AutoFilter
Set tr = rng

For r = 1 To rng.Rows.Count
key = ws.Cells(r, 1).Text
If WorksheetFunction.CountIf(ws.Cells(1, 1).Resize(r), key) = 1 Then

rng.AutoFilter 1, key
sh.Cells.Clear
If r > 1 Then Set tr = Intersect(rng, rng.Offset(1))
tr.Copy Destination:=sh.Cells(1, 1)

Application.DisplayAlerts = False
wb.SaveAs Filename:=p & key & ".txt", FileFormat:=xlText, CreateBackup:=False
Application.DisplayAlerts = True

End If
Next r

rng.AutoFilter
wb.Close False
Application.ScreenUpdating = True

MsgBox "処理終了"
End Sub
この回答への補足あり
    • good
    • 1

何となく読んでみただけですけど。



B列の重複を削除って重複している場合のC列以降って同じデータなの?
仮に違うとしたら
・重複している行はすべて削除
・重複している場合は最初の行だけ残す
・重複している場合は最後だけ残す
と言う内容がわかるサンプルデータを提示されたら良かったかと。

あとは行列数の目星によってメモリが持つか否かかな?
CSV形式でってありながら .txt ファイルでの保存と言うのも不明ですし、データの区切りをカンマで行うとしてデータそのものにカンマが使われているのかとか。
B列無視でなら並び替えや抽出を考える事もないとは思いますけど、うちのはバージョンお古なのでこっちで出来ても今のExcelでどうかは不明。

ってもうご覧になってないかな?
この回答への補足あり
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング