Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Excel 2013)
マクロエクセルにある情報をテキスト化する作業について
投稿日時: 19/06/08 18:22:56
投稿者: macro_1

マクロがどうしてもうまくできずに大変困っております。どなたご教授いただけないでしょうか。
 
◯使用するsheetはりんご、みかん、ばなな、いちご、めろん
◯したいこと
@テキストを2つ作る。(テキスト1の名前はsheetりんごのB1、テキスト2の名前はsheetりんごのB2)(作成場所はthisworkbook.pathでマクロと同じ場所にする)
Aテキスト1の中身は『sheetりんごのC5からC列の最終行まで→sheetみかんはりんごと同様にC5から最終行まで→隣の列のD5が空白なら次のシートへ/空白でなければD5からD列の最終行まで→E5が,,,と空白まで繰り返す。(最大でBN列まで続く想定)→sheetばななのりんごと同様の作業→sheetいちごのりんごと同様の作業→sheetめろんのりんごと同様の作業』とする。
Bテキスト2の中身は『sheetりんごのD5からD列の最終行まで→sheetみかんはりんごと同様にC5から最終行まで→隣の列のD5が空白なら次のシートへ/空白でなければD5からD列の最終行まで→E5が,,,と空白まで繰り返す。(最大でBN列まで続く想定)→sheetばななのりんごと同様の作業→sheetいちごのりんごと同様の作業→sheetめろんのりんごと同様の作業』とする。(テキスト2とテキスト1のみかんの箇所のみ同内容になる想定)
※みかんのみ他シートと異なる作業であるが、テキストに書き出す順は上記のまま
※りんご、ばなな、いちご、めろんはE列以降、みかんはBO列以降は関数も何も入っていない空白セル
※りんご、ばなな、いちご、めろんはD列まで、みかんはBN列までの各セルは、下記例のように@if関数で値が表示されているセルAif関数で空白となっているセルB関数も何も記載がない空白のセルの3つが入り混じっている
※りんご、ばなな、いちご、めろんはD列まで、みかんはBN列までの5行目(D5,E5等)にはif関数が入っており、関数の結果で空白か値が入るかとしている
※下記例のような場合は関数が入っていて空白のD15ではなく、それを除いたD11をD列の最終セルとしたい。(D11までの関数が入っていて空白のD8はテキストに書き出す)
 
例:
  D
5 abcde 5
6 
7 fghij 5
8 “”←(『=IF($A8<>1,”◯”,””)で空白となっている』
9 5
10 
11 5
12 “”←(『=IF($A12<>1,”◯”,””)で空白となっている』
13 “”←(『=IF($A13<>1,”◯”,””)で空白となっている』
14 “”←(『=IF($A14<>1,”◯”,””)で空白となっている』
15 “”←(『=IF($A15<>1,”◯”,””)で空白となっている』
16 『以下、関数含め何もなし』

回答
投稿日時: 19/06/08 18:50:24
投稿者: mattuwan44

>マクロがどうしてもうまくできずに大変困っております。
長文で書かれると内容が分かり難い(VBAにも翻訳しにくい)ので、
まずは作業手順を箇条書きにしてみましょう。
また、2種類の結果が欲しい場合は、一旦それぞれ別々に考えてみましょう。
 
1パターン目>

1)ブック内のシート群に対して繰り返す
  <各シートに対しての処理>
  2)シートを新規ブックにコピーする
  3)新しく出来たブックのシートの
    4)B1の値をシート名の欄に仮に記録しておく
    5)C5セルより右方向と下方向を見て、数式が空白を返しているセルをホントの空白に置き換える
     (A列,B列も空白にする?もうなってる?)
    6)使っているセル範囲の内、空白セルをキーにして、不要な行および列を削除する。
  7)新しく出来たブックをテキストファイルとして、シート名で保存する
8)次のシート(最後まで繰り返したら終わり)

 
こんな感じですかね?
間違っていたら訂正してください。
 

回答
投稿日時: 19/06/08 18:52:29
投稿者: simple

「テキスト」とは「テキストファイル」のことですね?
どこまでできているのですか?
途中までで結構ですから、アップして下さい。

回答
投稿日時: 19/06/08 20:20:18
投稿者: WinArrow
投稿者のウェブサイトに移動

説明が非常にわかりにくい
 
>うまくいかない
うまいか/まずいか・・は、回答者にはわかりません。
要は、意図する結果にならないってことですよね?
 
ということは、
ここまでは、意図するが、ここからは意図する結果にならない・・・または、エラーが出て進まない
 
というようなことだと思う
 
(1)状況の説明(シート、セルのレイアウトなど)
(2)意図する結果
(3)実際の実行結果
 
というよう説明ができるでしょうか?
 
テキスト1の名前に「りんご」とかセルの名前は紛らわしい。
説明上は、「テキスト1フィル」というような表現でよい。
実際の名前はあなたが修正すればよいでしょう。
 
テキストファイルへの出力方法は、いくつかあるが、
1列だけにするか、範囲にするかを明示しましょう。
1列だけにするとは、C列を書き出したら、次にD列を書き出す・・・・・というような感じ
 

投稿日時: 19/06/08 20:46:30
投稿者: macro_1

読みづらい文章で申し訳ありません。
 
excelには各シートに関数が記載されており、excel内で書き換えたり削除したり保存したりはせずにデータのある箇所を.txtにて書き出したいです。
 
Sub macro1()
    Dim WS as Worksheet
    Set WS = ThisWorkbook.Worksheets(“1”)
    Open ThisWorkbook.Path & “\” & WS.cells(1,2) & “.txt”
        _ For Output As #1
でsheet1のB1の値でテキスト名を決め、その中身は
@sheet1のC5からC列の記載のある最下セルまで、
Asheet2のC5からC列の記載のある最下セルまで、(右隣の列が空セルでなければその列も書き出す)
Bsheet3のC5からC列の記載のある最下セルまで、
Csheet4のC5からC列の記載のある最下セルまで、
Dsheet5のC5からC列の記載のある最下セルまで、とする。
 
もうひとつ
    Open ThisWorkbook.Path & “\” & WS.cells(2,2) & “.txt”
        _ For Output As #1
でsheet1のB2の値でテキスト名を決め、その中身は
@sheet1のD5からD列の記載のある最下セルまで、
Asheet2のC5からC列の記載のある最下セルまで、(右隣の列が空セルでなければその列も書き出す)
Bsheet3のD5からD列の記載のある最下セルまで、
Csheet4のD5からD列の記載のある最下セルまで、
Dsheet5のD5からD列の記載のある最下セルまで、とする。

回答
投稿日時: 19/06/08 20:50:40
投稿者: WinArrow
投稿者のウェブサイトに移動

追加レス
>関数が入っていて空白
>何も入っていない空白
 
これは正式には
【空白】とは、何も入っていないこと
【空白文字列】関数等で長さ:0の文字列をいいます。
混同しないようにしましょう。
 
因みに
例えば
IF Range("D1").Value = "" Then
という判断文では、上の「空白」と「空白文字列」を区別できません。
 
If ISEmpy(Range("D1").Value) Then
で、「空白」が判断できます。

回答
投稿日時: 19/06/08 21:03:35
投稿者: mattuwan44

だいぶイメージは掴めましたが、
4行目とB列は空白ですか?
表に項目名とか入ってますか?
 
出力したいセル範囲を特定するのに、
表の区切りとして、空白行および空白列で囲まれていると、
表の範囲が可変であっても、特定しやすいので、いろいろ質問しています。
あと、行数のキーになるC列は、空白を返す数式が下にもずらっと並んでいますか?

回答
投稿日時: 19/06/08 21:20:29
投稿者: simple

ポイントは値の入っている最終行を求めるところ。
これは、一行目から xlPrevious方向に検索することで求められます。
下記のgetLastRowプロシージャを参照してください。
 
文字列は単に改行コードを付けて連結していけばいいわけですね。
そういう前提で部品を提供します。
これを組み合わせてみて下さい。
 

'その列の値がある最終行の行番号を返す
Function getLastRow(r As Range) As Long
    Dim rng As Range
    Set rng = r.find(What:="*", After:=r.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, _
           SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
           MatchCase:=False, MatchByte:=False, SearchFormat:=False)
    getLastRow = rng.Row
End Function

'その一列のセル範囲の文字列を改行コードで連結する
Function getText(r As Range)
    getText = Join(Application.Transpose(r), vbCrLf)
End Function

'1列パターン
Function work1(ws As Worksheet)
    Dim r As Long
    Dim s As String
    
    r = getLastRow(ws.Columns(3))
    s = getText(ws.Range(ws.Range("C5"), ws.Cells(r, "C")))
    Print #1, s
End Function

'複数列パターン
Function work2(ws As Worksheet)
    Dim r As Long
    Dim s As String
    Dim k As Long
    
    For k = 3 To 66     'C列からBN列まで
        If ws.Cells(5, k) <> "" Then
            r = getLastRow(ws.Columns(k))
            s = getText(ws.Range(ws.Cells(5, k), ws.Cells(r, k)))
            Print #1, s
        Else
            Exit For
        End If
    Next
End Function

回答
投稿日時: 19/06/08 21:48:34
投稿者: WinArrow
投稿者のウェブサイトに移動

>@sheet1のC5からC列の記載のある最下セルまで、
について
 
この文章をコードにすると
 
With Sheets("Sheet1")
    .Range(,Rabge("C5"),.Range("C" & .Rows.COunt).End(xlup))
 
というような形になります。
下からデータの入っているセル(空白でないセル)を探すコードが
>Range("C" & .Rows.COunt).End(xlup)
です。
上から探す方法では、最初の空白セルの一つ前までとなります。
 
途中の空白も書き出すということならば
     For Each myCELL In .Range(.Range("C5"),.Range("C" & .Rows.Count).End(xlup))
         Print #1,myCell.Value
     Next
で、「値の入っている最終セルまで、書き出すことができます。
参考にしてください。
※テキストファイルでは「空白」も「空白文字列」も同じになります。
 
もう一つの注意
#1
は使わない方がよいでしょう
Dim FNo As Integer
FNo = FreeFile
Open ○○ For Output AS #FNo
Print #FNo,セル
Close (FNo)
のように使います。
同時に2つのテキストファイルを扱う場合に便利です。
 

投稿日時: 19/06/08 21:49:36
投稿者: macro_1

mattuwan44様
返答ありがとうございます。
4行目は空白ですが、B列はテキストファイルのファイル名用にB1とB2は空白ではありません。
表に項目名はありません。
C列に数式は一番下までではないですが複数並んでいます。

回答
投稿日時: 19/06/08 21:54:29
投稿者: simple

あ、よく読んでいなかったが、対象列が違うのですね。
そしたら、以下のような開始列と終了列をした関数とすればいいですね。

'複数列パターン
Function work(ws As Worksheet, startCol As Long, endCol As Long)
    Dim r As Long
    Dim s As String
    Dim k As Long
    
    For k = startCol To endCol     
        If ws.Cells(5, k) <> "" Then
            r = getLastRow(ws.Columns(k))
            s = getText(ws.Range(ws.Cells(5, k), ws.Cells(r, k)))
            Print #1, s
        Else
            Exit For
        End If
    Next
End Function

単一列なら Call work(Worksheets(1), 3, 3 )
複数列なら Call work(Worksheets(1), 3, 66 )
とかの使い方です。

投稿日時: 19/06/08 22:02:44
投稿者: macro_1

皆様
お助けいただきありがとうございます。
いただいた情報を元に考えてみようと思います。
初心者の駄文でご迷惑をおかけしたと思いますが、お付き合いいただきありがとうございます。

回答
投稿日時: 19/06/08 22:17:02
投稿者: simple

WinArrowさんのFreeFileを使うべきというご指摘はそのとおりですね。
 
ところで、End(xlUP)を使うと、""を返す計算式があるセルは、
非空白でそこが最終行と判断されますよね。
それは本来書込対象外じゃないかったですか?
それだと、Print したときに、余分な改行コードだけの行が入ってしまうのではないのですか?
私が勘違いしているのかなあ。

回答
投稿日時: 19/06/08 22:42:30
投稿者: simple

WinArrowさん
すみません。
提示頂いたコードを実行すると、
質問者さんの最初の投稿にある
>※下記例のような場合は関数が入っていて空白のD15ではなく、それを除いたD11をD列の最終セルとしたい。
ということになりますか?
D15までが対象になりませんか?

回答
投稿日時: 19/06/08 22:45:02
投稿者: WinArrow
投稿者のウェブサイトに移動

ヒントのコードを紹介します。
  
シート名を配列にする
アクセスしたい順序でシート名を記述すれば、シートの並びを意識する必要はない。
シートの位置は自由に変更できます。(変更される可能性がある)
シートによって列が異なるので、列を変数化する
 など
 テキストファイル出力ルーチンを一本化する。
 途中の空白セルも出力対象とする
  
参考コード
Option Explicit
   
 Sub test()
   
 Dim ShtName, Sx As Long, Rx As Long
 Dim data
 Dim 列 As String
 Dim Fno As Integer
   
     Fno = FreeFile
     Open ThisWorkbook.Path & "\" & Sheets("Sheet1").Range("B1").Value & ".txt" For Output As #Fno
     ShtName = Array("Sheet2", "Sheet3", "Sheet1")
     For Sx = LBound(ShtName) To UBound(ShtName)
         Select Case CStr(ShtName(Sx))
             Case "Sheet1", "SHeet3"
                 列 = "C"
             Case Else
                 列 = "D"
         End Select
           
         With Sheets(ShtName(Sx))
             data = .Range(.Range(列 & 5), .Range(列 & .Rows.Count).End(xlUp)).Value
             data = WorksheetFunction.Transpose(data)
         End With
         Print #Fno, Join(data, vbLf)
     Next
     Close (Fno)
   
 End Sub

回答
投稿日時: 19/06/08 22:52:11
投稿者: simple

あれえ、コードを拝見してからコメントしたのですが、逆順になってしまっています。

回答
投稿日時: 19/06/08 23:00:27
投稿者: WinArrow
投稿者のウェブサイトに移動

simple さんの引用:
WinArrowさんのFreeFileを使うべきというご指摘はそのとおりですね。
 
ところで、End(xlUP)を使うと、""を返す計算式があるセルは、
非空白でそこが最終行と判断されますよね。
それは本来書込対象外じゃないかったですか?
それだと、Print したときに、余分な改行コードだけの行が入ってしまうのではないのですか?
私が勘違いしているのかなあ。

 
冒頭の説明は、よくわかりませんでした。
投稿日時: 19/06/08 20:46:30
の説明で、記載のある最終行
をそのまま解釈しました。
 
「空白」と「空白文字列」は区別しましょう
とレスしたが、一歩遅かったみたいですね?
 
おっしゃれる通り、余分な改行だけの行が書き出されます。
 
 

回答
投稿日時: 19/06/08 23:07:48
投稿者: simple

了解しました。
これは質問者さんがコメントすべきことでした。

回答
投稿日時: 19/06/08 23:20:40
投稿者: WinArrow
投稿者のウェブサイトに移動

最後の余分な改行だけの行を排除したコードに修正してみました。
  
Sub test()
   
 Dim ShtName, Sx As Long, Rx As Long
 Dim data
 Dim 列 As String, LastCell As Range
 Dim Fno As Integer
   
     Fno = FreeFile
     Open ThisWorkbook.Path & "\" & Sheets("sheet1").Range("B1").Value & ".txt" For Output As #Fno
     ShtName = Array("Sheet1", "Sheet3", "Sheet1")
     For Sx = LBound(ShtName) To UBound(ShtName)
         Select Case CStr(ShtName(Sx))
             Case "Sheet1", "SHeet3"
                 列 = "C"
             Case Else
                 列 = "D"
         End Select
         With Sheets(ShtName(Sx))
             Set LastCell = .Range(.Range(列 & 5), .Range(列 & .Rows.Count).End(xlUp)).Find( _
                 What:="*", _
                 after:=.Range(列 & .Rows.Count).End(xlUp), _
                 LookIn:=xlValues, _
                 LookAt:=xlWhole, _
                 SearchOrder:=xlByRows, _
                 SearchDirection:=xlPrevious)
             data = .Range(.Range(列 & 5), LastCell).Value
             data = WorksheetFunction.Transpose(data)
         End With
         Print #Fno, Join(data, vbLf)
     Next
     Close (Fno)
   
 End Sub

回答
投稿日時: 19/06/09 07:36:50
投稿者: simple

全体を示しておきます。
参考にして下さい。
 

Option Explicit
Dim fnum    As Long ' ファイル番号

Sub main()
    Dim fname   As String
    Dim k       As Long
    Dim ary     As Variant
    Dim col(1 To 2) As Long
    
    col(1) = 3  '最初のテキストファイル作成に使用する列番号
    col(2) = 4  '2番目のテキストファイル作成に使用する列番号
    
    For k = 1 To 2
        fname = ThisWorkbook.Path & "\" _
                & Worksheets("Sheet1").Range("B1").Offset(k - 1).Value
        fnum = FreeFile
        Open fname For Output As #fnum

        Call work(Worksheets("Sheet1"), col(k), col(k))
        Call work(Worksheets("Sheet2"), 3, 66) 'C列からBN列まで
        For Each ary In Array("Sheet3", "Sheet4", "Sheet5")
            Call work(Worksheets(ary), col(k), col(k))
        Next

        Close #fnum
    Next
End Sub

'wsシートのstartCol列からendCol列までをテキストファイルに転記
Function work(ws As Worksheet, startCol As Long, endCol As Long)
    Dim r As Long
    Dim s As String
    Dim k As Long
    
    For k = startCol To endCol
        If ws.Cells(5, k) <> "" Then
            r = getLastRow(ws.Columns(k))
            s = getText(ws.Range(ws.Cells(5, k), ws.Cells(r, k)))
            Print #fnum, s
        Else
            Exit For
        End If
    Next
End Function

'その列の値がある最終行の行番号を返す
Function getLastRow(rng As Range) As Long
    Dim r As Range
    Set r = rng.find(What:="*", After:=rng.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, _
           SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
           MatchCase:=False, MatchByte:=False, SearchFormat:=False)
    getLastRow = r.Row
End Function

'その一列のセル範囲の文字列を改行コードで連結する
Function getText(rng As Range)
    getText = Join(Application.Transpose(rng), vbCrLf)
End Function

投稿日時: 19/06/12 21:30:45
投稿者: macro_1

解決できました。みなさま色々教えていただきありがとうざいました。