Excel VBA質問箱 IV

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

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


62124 / 76732 ←次へ | 前へ→

【19216】Re:固定長のテキストをスマートに切りだしながら取り込みたい
回答  Hirofumi  - 04/10/25(月) 20:18 -

引用なし
パスワード
   こんなやり方も有るよ
基本的には、BinaryモードでInputB関数で読み込みます
「読込設定」と言う名前の、WorkSheetを作り、
このシートに設定したバイト数、列見出し、書式、Fillerを使用してファイルを読み込みます
WorkSheets("読込設定")の、B1から、C1、D1・・・と列見出しと成る文字列をセルに書き込みます
同じく、B2、C2、D2・・・と、ファイールドのバイト長を設定します
同じく、B3、C3、D3・・・と、セルの書式を数値で設定します(1が標準、2が文字列、3が日付、設定無しの場合は標準)
同じく、WorkSheets("読込設定")のB6には、改行コードのバイト数を設定(vbCrLfなら2、改行コード無しなら0)
データが書き込まれるWorkSheetは、Upしたコードではアクティブシートです
検証不足なので上手くいかなかったらゴメン

Option Explicit

Public Sub ReadFixdTextBin()

  Dim wksSetUp As Worksheet
  Dim wksWrite As Worksheet
  Dim vntFieldLen As Variant
  Dim lngRecLen As Long
  Dim lngLineMax As Long
  Dim vntFileName As Variant
  Dim lngWriteRow As Long
  Dim lngWriteCol As Long

  'ディフォルトのファイル名を指定
'  vntFileName = "TestFile.txt"
  If Not GetReadFile(vntFileName, ThisWorkbook.Path, False) Then
    Exit Sub
  End If
  'Openするファイル名を設定
'  vntFileName = ThisWorkbook.Path & "\" & "TestFile.txt"
'  If Dir(vntFileName) = "" Then
'    Beep
'    MsgBox vntFileName & vbCrLf & "ファイルが有りません"
'    Exit Sub
'  End If

  '画面更新を停止
  Application.ScreenUpdating = False
  
  '書き込み行の初期値を設定
  lngWriteRow = 1
  '書き込み列の初期値を設定
  lngWriteCol = 1
  '「設定」シートの参照を設定
  Set wksSetUp = ThisWorkbook.Worksheets("読込設定")
  '書き込むシート名の参照を設定
  Set wksWrite = ActiveSheet
  
  '設定シートよりフィールド情報の読み込み
  lngRecLen = GetReadField(vntFieldLen, wksSetUp)
  
  '総行数確認
  lngLineMax = FileLen(vntFileName) \ lngRecLen
  If lngLineMax + lngWriteRow > 65536 Then
    Beep
    MsgBox "Dataが" & lngLineMax & _
      "行有り、65536行を超えています", _
          vbExclamation + vbOKOnly, "OverFlow"
    Exit Sub
  End If
  
  '列見出しの書き込み
  PutFieldNames lngWriteRow, lngWriteCol, wksSetUp, wksWrite
  lngWriteRow = lngWriteRow + 1
  
  'セルの書式設定
  CellsFormat lngWriteRow, lngWriteCol, _
          vntFieldLen, lngLineMax, wksWrite
  
  
  SDFRead vntFileName, vntFieldLen, lngRecLen, _
        wksWrite, lngWriteRow, lngWriteCol
  
  With wksWrite
    .Cells.EntireColumn.AutoFit
    .Cells(1, 1).Select
  End With
  
  Set wksSetUp = Nothing
  Set wksWrite = Nothing
  
  '画面更新を再開
  Application.ScreenUpdating = True
    
  Beep
  MsgBox "処理が終了しました", vbOKOnly, "終了"
    
End Sub

Private Sub SDFRead(ByVal strFileName As String, _
          vntFieldLen As Variant, _
          lngRecLen As Long, _
          ByVal wksWrite As Worksheet, _
          Optional lngRow As Long = 2, _
          Optional lngCol As Long = 1)

  'lngRow = 2 : シートのデータ書き込み先頭行位置
  'lngCol = 1 : シートのデータ書き込み先頭列位置
  
  Dim dfn As Integer
  Dim vntField As Variant
  Dim lngNumb As Long

  '設定シートよりフィールド数の取得
  lngNumb = UBound(vntFieldLen, 2)
  
  '読み込むファイルをBinaryファイルとしてOpen
  dfn = FreeFile
  Open strFileName For Binary Access Read As dfn

  '最終バイト数まで繰り返す
  Do Until LOF(dfn) <= Loc(dfn)
    'フィールドData作成
    vntField = DivideStrBinary(InputB(lngRecLen, #dfn), vntFieldLen)
    'List書きこみ
    With wksWrite.Cells(lngRow, lngCol)
      .Offset.Resize(, lngNumb).Value = vntField
    End With
    '書き込み行の更新
    lngRow = lngRow + 1
  Loop

  Close #dfn

End Sub

Private Function GetReadField(vntField As Variant, _
            ByVal wksSetUp As Worksheet) As Long

'  設定Field長、書式の読み込み

  Dim i As Long
  Dim lngColEnd As Long
  Dim lngLen As Long
  
  With wksSetUp
    lngColEnd = .Cells(2, 256).End(xlToLeft).Column
    vntField = .Range(.Cells(2, 2), .Cells(3, lngColEnd)).Value
    'レコード長の算出
    lngLen = Val(.Cells(6, 2).Value)
    For i = 1 To UBound(vntField, 2)
      lngLen = lngLen + CLng(vntField(1, i))
    Next i
  End With

  GetReadField = lngLen
  
End Function

Private Sub CellsFormat(lngRow As Long, _
            lngCol As Long, _
            vntFieldAtt As Variant, _
            lngMaxLine As Long, _
            wksWrite As Worksheet)

'  セルの書式設定
  
  Dim i As Long
  
  With wksWrite.Cells(lngRow, lngCol)
    For i = 0 To UBound(vntFieldAtt, 2) - 1
      If vntFieldAtt(2, i + 1) <> "" Then
        With .Offset(, i).Resize(lngMaxLine)
          Select Case vntFieldAtt(2, i + 1)
            Case 1
              .NumberFormatLocal = "G/標準"
            Case 2
              .NumberFormatLocal = "@"
            Case 3
              .NumberFormatLocal = "yyyy/mm/dd"
          End Select
        End With
      End If
    Next i
  End With
  
End Sub

Private Sub PutFieldNames(lngRow As Long, _
            lngCol As Long, _
            ByVal wksSetUp As Worksheet, _
            ByVal wksWrite As Worksheet)

'  列見出しの書きこみ

  Dim lngColEnd As Long
  
  If lngRow <= 0 Then
    Exit Sub
  End If
  
  With wksSetUp
    lngColEnd = .Cells(1, 256).End(xlToLeft).Column
    .Range(.Cells(1, 2), .Cells(1, lngColEnd)).Copy _
      Destination:=wksWrite.Cells(lngRow, lngCol)
  End With
  
End Sub

Private Function DivideStrBinary(ByVal strLine As String, _
                vntLength As Variant) As Variant

'  フィールドDataに分割

  Dim i As Long
  Dim lngPos As Long
  Dim vntField As Variant
  Dim intDataMax As Integer
  
  lngPos = 1
  intDataMax = UBound(vntLength, 2)
  ReDim vntField(intDataMax - 1)
  For i = 1 To intDataMax
    vntField(i - 1) _
        = Trim(StrConv(MidB(strLine, _
            lngPos, CLng(vntLength(1, i))), vbUnicode))
    lngPos = lngPos + CLng(vntLength(1, i))
  Next i
  
  DivideStrBinary = vntField
  
End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 3, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

2 hits

【19205】固定長のテキストをスマートに切りだしながら取り込みたい ackkn 04/10/25(月) 16:01 質問
【19207】Re:固定長のテキストをスマートに切りだし... Kein 04/10/25(月) 16:34 回答
【19210】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/25(月) 17:19 発言
【19209】Re:固定長のテキストをスマートに切りだし... Jaka 04/10/25(月) 17:04 回答
【19211】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/25(月) 17:29 発言
【19212】Re:固定長のテキストをスマートに切りだし... Jaka 04/10/25(月) 17:41 回答
【19214】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/25(月) 19:14 質問
【19215】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/25(月) 20:12 質問
【19230】Re:固定長のテキストをスマートに切りだし... Jaka 04/10/26(火) 9:43 回答
【19233】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/26(火) 12:06 発言
【19256】Re:固定長のテキストをスマートに切りだし... Jaka 04/10/26(火) 16:54 発言
【19282】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/27(水) 12:08 質問
【19283】Re:固定長のテキストをスマートに切りだし... Jaka 04/10/27(水) 12:37 発言
【19303】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/27(水) 20:11 お礼
【19216】Re:固定長のテキストをスマートに切りだし... Hirofumi 04/10/25(月) 20:18 回答
【19223】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/25(月) 22:50 発言
【19270】Re:固定長のテキストをスマートに切りだし... ackkn 04/10/27(水) 9:48 質問
【19304】Re:固定長のテキストをスマートに切りだし... Hirofumi 04/10/27(水) 20:57 回答
【19434】Re:固定長のテキストをスマートに切りだし... ackkn 04/11/2(火) 18:35 お礼

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