Excel VBA質問箱 IV

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

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


56414 / 76732 ←次へ | 前へ→

【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

よろしくお願いします。

0 hits

【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 回答

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