| |
ウッシさんさん
ご返答ありがとうございます。
>「ユーザー定義型は定義されていません」とエラー表示
> レスしたコードは標準モジュールから貼り付けて下さいね。
> 特に「Type recFormat 〜 End Type」
標準モジュールの先頭からつけてみましたが、またエラーが表示されてしまいます。
下記のマクロが最初からある場合には、どこに挿入してよいか教えてください。
シート１
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
よろしくお願いします。
|
|
パズラー
- 05/5/19(木) 11:18 -
