Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9857 / 13644 ツリー ←次へ | 前へ→

【25061】固定長データへの出力 パズラー 05/5/19(木) 9:53 質問[未読]
【25063】Re:固定長データへの出力 ウッシ 05/5/19(木) 10:02 回答[未読]
【25065】Re:固定長データへの出力 パズラー 05/5/19(木) 10:25 質問[未読]
【25067】Re:固定長データへの出力 ウッシ 05/5/19(木) 10:36 回答[未読]
【25071】Re:固定長データへの出力 パズラー 05/5/19(木) 11:18 質問[未読]
【25073】Re:固定長データへの出力 ウッシ 05/5/19(木) 11:33 回答[未読]
【25074】Re:固定長データへの出力 パズラー 05/5/19(木) 11:46 質問[未読]
【25075】Re:固定長データへの出力 ウッシ 05/5/19(木) 11:55 回答[未読]
【25097】Re:固定長データへの出力 パズラー 05/5/20(金) 10:17 お礼[未読]
【25088】Re:固定長データへの出力 Hirofumi 05/5/19(木) 18:43 回答[未読]

【25061】固定長データへの出力
質問  パズラー E-MAIL  - 05/5/19(木) 9:53 -

引用なし
パスワード
   パズラーです、よろしくお願いします。
(Windows2000/Excel2000)

未熟な質問なんですが、マクロで編集したデータを固定長での出力の仕方がわかりません。
どなたかご教授いただけたら幸いです。

【25063】Re:固定長データへの出力
回答  ウッシ  - 05/5/19(木) 10:02 -

引用なし
パスワード
   こんにちは

ごく単純な例で、

Type recFormat
  f1 As String * 4
  f2 As String * 10
  f3 As String * 15
End Type

Sub test()
  Dim rFormat As recFormat
  Dim fN   As Integer
  Dim myPath As String
  Dim mArray
  Dim i    As Long
  
  fN = FreeFile
  myPath = ThisWorkbook.Path
  Open myPath & "\test.dat" For Binary As #fN
  
  'データは C列までとする
  mArray = Range("A1").CurrentRegion.Value
  
  For i = 1 To UBound(mArray, 1)
    rFormat.f1 = mArray(i, 1)
    rFormat.f2 = mArray(i, 2)
    rFormat.f3 = mArray(i, 3)
    
    Put #fN, , rFormat
    Put #fN, , vbCrLf
  Next
  Close #fN
End Sub

【25065】Re:固定長データへの出力
質問  パズラー E-MAIL  - 05/5/19(木) 10:25 -

引用なし
パスワード
   ウッシさん、おはようございます。
ご返答ありがとうございます。

非常に初心者なので、ご教示ください。
下ので実行するとエラーがでます。
ここの部分でひっかかるのですが

Dim rFormat As recFormat

上記の一文に対して「ユーザー定義型は定義されていません」とエラー表示されます。

【25067】Re:固定長データへの出力
回答  ウッシ  - 05/5/19(木) 10:36 -

引用なし
パスワード
   こんにちは

>「ユーザー定義型は定義されていません」とエラー表示
レスしたコードは標準モジュールの先頭から貼り付けて下さいね。
特に「Type recFormat 〜 End Type」は。

【25071】Re:固定長データへの出力
質問  パズラー E-MAIL  - 05/5/19(木) 11:18 -

引用なし
パスワード
   ウッシさんさん
ご返答ありがとうございます。

>「ユーザー定義型は定義されていません」とエラー表示
> レスしたコードは標準モジュールから貼り付けて下さいね。
> 特に「Type recFormat 〜 End Type」

標準モジュールの先頭からつけてみましたが、またエラーが表示されてしまいます。

下記のマクロが最初からある場合には、どこに挿入してよいか教えてください。

シート1

Const quotes As String = """"

Sub TXT読み込み()
  Const Msg1 As String = "の"
  Const Msg2 As String = "行目を読み込んでいます。"
  Dim file_name As String, FileNum As Integer
  Dim rn As Integer, cn As Integer, cs As Integer
  Dim CurTxt As String, DeLimiter As String
  
  file_name = Application.GetOpenFilename( _
    "テキストファイル (*.txt; *.csv; *.prn; *.dat),*.txt; *.csv; *.prn; *.dat", _
     1, "読み込むファイルを開いてください")
  If file_name = "False" Then Exit Sub
  
  DeLimiter = SetDelimiter()
  
  Application.StatusBar = file_name & "を開いています。"
  FileNum = FreeFile()
  Open file_name For Input Access Read As #FileNum
  
  On Error GoTo CloseCSV
  
  Do Until EOF(FileNum)
    rn = rn + 1
    Application.StatusBar = file_name & Msg1 & rn & Msg2
    Line Input #FileNum, CurTxt
    Call ReadLine(CurTxt, DeLimiter, rn)
  Loop

  Application.StatusBar = False
  Close #FileNum
  MsgBox file_name & "を読み込みました。", , "完了"
  Exit Sub
  
CloseCSV:
  Application.StatusBar = False
  MsgBox "読み込みに失敗したので、ファイルを閉じます。" & Chr(10) & _
    "読み込み元のファイルをチェックしてください。"
  Close #FileNum
End Sub

Sub ReadLine(CurTxt As String, DeLimiter As String, rn As Integer)
  Dim StrStart As Integer, StrEnd As Integer
  Dim StrArray() As String, cn As Integer
  
  StrStart = 1
  'バイト単位で読むときは、第4引数を省略
  StrEnd = InStr(StrStart, CurTxt, DeLimiter, 1)
  Do Until StrEnd = 0
    cn = cn + 1
    ReDim Preserve StrArray(1 To cn)
    'バイト単位で読むときは、MidB
    StrArray(cn) = DelQuotes(Mid$(CurTxt, StrStart, StrEnd - StrStart))
    StrStart = StrEnd + 1
    'バイト単位で読むときは、第4引数を省略
    StrEnd = InStr(StrStart, CurTxt, DeLimiter, 1)
  Loop
  cn = cn + 1
  ReDim Preserve StrArray(1 To cn)
  'バイト単位で読むときは、MidB, LenB
  StrArray(cn) = DelQuotes(Mid$(CurTxt, StrStart, Len(CurTxt)))
  Range(Cells(rn, 1), Cells(rn, cn)).Value = StrArray()
End Sub

Function SetDelimiter() As String
  Const Msg1 As String = "区切り文字を指定してください。"
  Const Msg2 As String = "このまま OK すると、タブを区切り文字に使用します。"
  Dim DeLimiter As String
  
  Do
    DeLimiter = InputBox( _
      Msg1 & Chr(10) & Msg2, "TXT読み込み", Chr(9) _
    )
  Loop Until DeLimiter > ""
  
  SetDelimiter = DeLimiter
End Function

Function DelQuotes(CurTxt As String) As String
  DelQuotes = Application.Substitute(CurTxt, quotes, "")
End Function


シート2


Sub シート別分類()
  Dim us As Range
  Dim CodeIndex As Integer
  Dim UniqueArray As Variant
  Dim rn As Integer
  
  Set us = ActiveSheet.UsedRange
  '分類する項目(列)を指定
  CodeIndex = Application.InputBox( _
    "振り分ける項目を選択してください", "シート別分類", _
    , , , , , 8).Column
  UniqueArray = GetUniqueArray(us, CodeIndex)
  '振り分ける項目第2要素から最終要素まで(第1は見出しとして除く)
  For rn = 2 To UBound(UniqueArray)
    Call AddNewSheets(UniqueArray(rn, 1), us, CodeIndex)
  Next
  Application.StatusBar = False
  us.AutoFilter
End Sub

Sub AddNewSheets(NewName As Variant, us As Range, CodeIndex As Integer)
  Dim AnotherSheet As Worksheet
  
  Application.StatusBar = NewName & "について検索中"
  us.AutoFilter field:=CodeIndex, Criteria1:=NewName
  Set AnotherSheet = Worksheets.Add
  us.SpecialCells(xlVisible).EntireRow.Copy (AnotherSheet.Cells(1, 1))
  AnotherSheet.Name = NewName
End Sub

Function GetUniqueArray(us As Range, CodeIndex As Integer) As Variant
  Dim NewSheet As Worksheet
  
  Set NewSheet = Worksheets.Add
  us.Columns(CodeIndex).AdvancedFilter _
    Action:=xlFilterCopy, _
    copyToRange:=NewSheet.Range("A1"), _
    criteriaRange:=us.Columns(CodeIndex), _
    unique:=True
  GetUniqueArray = NewSheet.UsedRange
  
  Application.DisplayAlerts = False
  NewSheet.Delete
  Application.DisplayAlerts = True
End Function

よろしくお願いします。

【25073】Re:固定長データへの出力
回答  ウッシ  - 05/5/19(木) 11:33 -

引用なし
パスワード
   こんにちは

「標準モジュール」は分かりますか?

【25074】Re:固定長データへの出力
質問  パズラー  - 05/5/19(木) 11:46 -

引用なし
パスワード
   ▼ウッシ さん:
>こんにちは

ウッシさん
ご迷惑をおかけします。

>「標準モジュール」は分かりますか?
解りません

【25075】Re:固定長データへの出力
回答  ウッシ  - 05/5/19(木) 11:55 -

引用なし
パスワード
   こんにちは

ブックを起動して「Alt+F11」キーでVBE画面(VBAコードを編集するエディタ)を開きます。
その画面のメニューの「挿入」から「標準モジュール」を選択して下さい。
そうすると「Module1」という標準モジュールが出来ますので画面右側のコードペインに
先のコードをコピペして一旦保存して下さい。

マクロの実行方法は分かりますよね?

簡単なサンプルですけどアクティブシートのA〜C列のデータをマクロブックと同じフォルダ
に「test.dat」という固定長ファイルにします。

【25088】Re:固定長データへの出力
回答  Hirofumi  - 05/5/19(木) 18:43 -

引用なし
パスワード
   こんな方法も有ります
基本的に文字数を勘定する方式を取ります
出力する、フィールドのバイト長等を設定するシートを作り、このシートの設定に従いTextを出力します
また、コードは、標準モジュールが、VBEの「挿入」→「標準モジュール(M)」で追加されますので
この標準モジュールに記述して下さい(コピペ)

次に「書込設定」と言う名前の、WorkSheetを作り、
このシートに設定したバイト数、列見出し、書式、Fillerを使用してファイルを書込みます
WorkSheets("書込設定")の、B1から、C1、D1・・・と列見出しと成る文字列をセルに書き込みます
同じく、B2、C2、D2・・・と、ファイールドのバイト長を設定します
同じく、B3、C3、D3・・・と、出力フィールドの右詰、左詰を文字で設定します
(右詰なら"R"or"r"、左詰なら"L"or"l")
同じく、WorkSheets("書込設定")のB6には、必要が有ればFillerをバイト数で設定
(Fillerは、レコード長調整用のスペース文字)
同じく、WorkSheets("書込設定")のB9には、改行コードの種類を番号で設定
(vbCrLf = 1、vbCr = 2、vbLf = 3、無し = 0)

出力データが有るWorkSheetは、Upしたコードではアクティブシートです
また、データの列数は、"書込設定"に設定した、列数を使用します

Option Explicit

Public Sub WriteFixdText()

  Dim vntFileName As Variant
  Dim wksSetUp As Worksheet
  Dim wksRead As Worksheet
  Dim lngReadRow As Long
  Dim lngReadCol As Long
  Dim strFiller As String
  Dim vntFieldLen As Variant
  Dim strRetCode As String
  
  '出力名を設定します
'  vntFileName = ThisWorkbook.Path & "\" & "TestFile.txt"
  vntFileName = "TestFile"
  '出力名を取得します
  If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
    Exit Sub
  End If
  
  'データ行の初期位置設定
  lngReadRow = 2
  'データ列の初期位置設定
  lngReadCol = 1
  '「設定」シートの参照を設定
  Set wksSetUp = ThisWorkbook.Worksheets("書込設定")
  'データの有るシートの参照を設定
  Set wksRead = ActiveSheet
  
  'フィールド特性を取得
  strRetCode = GetWriteField(vntFieldLen, strFiller, wksSetUp)
  
  'ファイルに出力
  SDFWrite vntFileName, vntFieldLen, strFiller, _
          strRetCode, wksRead, lngReadRow, lngReadCol
  
  '「設定」シートの参照を破棄
  Set wksSetUp = Nothing
  '読み込むシートの参照を破棄
  Set wksRead = Nothing
  
  Beep
  MsgBox "処理が終了しました", vbOKOnly, "終了"

End Sub

Private Sub SDFWrite(ByVal strFileName As String, _
            vntFieldLen As Variant, _
            strFiller As String, _
            strRetCode As String, _
            ByVal wksRead As Worksheet, _
            lngReadRow As Long, _
            lngReadCol As Long)

  Dim dfn As Integer
  Dim i As Long
  Dim j As Long
  Dim lngRowEnd As Long
  Dim lngColEnd As Long
  Dim strBuf As String
  Dim vntField As Variant
  
  
  '出力最終列を設定
  lngColEnd = UBound(vntFieldLen, 2)
  '出力最終行を取得
  With wksRead
    lngRowEnd = .Cells(65536, lngReadCol).End(xlUp).Row
  End With
  
  '空きファイル番号を取得します
  dfn = FreeFile
  '出力ファイルをOpenします
  Open strFileName For Output As dfn
    
  With wksRead.Cells(lngReadRow, lngReadCol)
    For i = 0 To lngRowEnd - lngReadRow
      '1行分のDataをシートから読みこむ
      vntField = Range(.Offset(i), _
                .Offset(i, lngColEnd - 1)).Value
      '出力1レコード作成
      strBuf = ""
      For j = 1 To lngColEnd
        strBuf = strBuf _
          & FieldStrings(vntFieldLen(1, j), _
                CStr(vntField(1, j)), vntFieldLen(2, j))
      Next j
      '出力レコードにFillerと改行コードを付加
      strBuf = strBuf & strFiller & strRetCode
      '1レコード書き出し
      Print #dfn, strBuf;
    Next i
  End With
  
  '出力ファイルを閉じる
  Close #dfn
  
End Sub

Private Function GetWriteField(vntField As Variant, _
              strFiller As String, _
              ByVal wksSetUp As Worksheet) As String

'  設定Field長の読み込み

  Dim i As Long
  Dim lngColEnd As Long
  Dim strRet As String
  
  With wksSetUp
    lngColEnd = .Cells(2, 256).End(xlToLeft).Column
    vntField = .Range(.Cells(2, 2), .Cells(3, lngColEnd)).Value
    strFiller = Space(Val(.Cells(6, 2).Value))
    Select Case .Cells(9, 2).Value
      Case 0
        strRet = ""
      Case 2
        strRet = vbCr
      Case 3
        strRet = vbLf
      Case Else
        strRet = vbCrLf
    End Select
  End With

  GetWriteField = strRet

End Function

Private Function FieldStrings(ByVal lngLength As Long, _
            ByVal strData As String, _
            Optional ByVal strAlign As String = "L") As String

'  Dataをフィールド長に調整

'  lngLengthはフィールドの長さを半角何文字分(バイト単位)で
'  strDataはデータを文字列の型で
'  strAlignは、右詰なら"R"、"r"で
'  左詰なら"L"、"l"で(ディフォルトは"L"、実際は、"R","r"以外なら左詰)
  
  Dim strSpace As String
  Dim i As Long
  Dim intCode As Integer
  
  If lngLength <= 0 Then
    FieldStrings = ""
    Exit Function
  End If
    
  '文字列を Unicode からシステムの既定のコード ページに変換します
  strData = StrConv(strData, vbFromUnicode)
  'フィールド長よりDataが長い場合、2バイト文字の処理を行います
  If LenB(strData) > lngLength Then
    strData = LeftB(strData, lngLength)
    intCode = Asc(Right$(StrConv(strData, vbUnicode), 1))
    If (0 <= intCode And intCode <= 7) _
        Or (11 <= intCode And intCode <= 12) _
        Or (14 <= intCode And intCode <= 31) _
        Or (127 <= intCode And intCode <= 159) _
        Or (224 <= intCode And intCode <= 255) Then
      strData = LeftB(strData, lngLength - 1)
    End If
  End If
  
  '長さ調整用のスペースを作成します
  If lngLength > LenB(strData) Then
    strSpace = StrConv(String$(lngLength _
            - LenB(strData), " "), vbFromUnicode)
    'Dataをフィールド長に調整します
    If strAlign = "R" Or strAlign = "r" Then
      strData = strSpace & strData
    Else
      strData = strData & strSpace
    End If
  End If
  
  'システムの既定のコード ページを使って文字列を Unicode に変換します
  FieldStrings = StrConv(strData, vbUnicode)
  
End Function

Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," & _
        "Text File (*.txt),*.txt"
  
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 2)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function

【25097】Re:固定長データへの出力
お礼  パズラー  - 05/5/20(金) 10:17 -

引用なし
パスワード
   ウッシさん おはようございます。

おかげさまでできました。
ありがとうございます。

9857 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free