Excel VBA質問箱 IV

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

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


74552 / 76732 ←次へ | 前へ→

【6642】Re:テキストファイルのインポート
回答  Jaka  - 03/7/16(水) 17:37 -

引用なし
パスワード
   >これだと新しいファイルが開くのですが、
開きません。ファイルのフルパスを取得だけです。

現在クエリが使える環境でないので(EXL97)、前に2000で試行錯誤していた途中のコードをのせますので、これを参考にしてみてください。
だいぶ前のなんで、覚えていませんが多分動くと思います。

Sub 対応版()
  Dim OpenFile As String
  Dim TBL() As Long, DataCnt As Long, STRow As Long
  Dim ReadDete As String, DData As Variant
  OpenFile = Application.GetOpenFilename("テキストファイル (*.txt), *.txt")
  If OpenFile = "False" Then
    End
  End If

  Stime = Now()
  Open OpenFile For Input As #1
  Line Input #1, ReadDete
  DataCnt = DataCnt + 1
  Do Until EOF(1)
    Line Input #1, DData
    DataCnt = DataCnt + 1
  Loop
  Close #1
  CNT = 0: WクォFlg = 0
  Range("A4").Value = ReadDete
  For i = 1 To Len(ReadDete)
    Range("A3").Value = Mid(ReadDete, i, 1)
    If Mid(ReadDete, i, 1) = "," And (WクォFlg = 0 Or WクォFlg = 2) Then
      CNT = CNT + 1
      ReDim Preserve TBL(1 To CNT)
      If WクォFlg = 0 Then
       TBL(CNT) = 1
      Else
       TBL(CNT) = 2
      End If
      WクォFlg = 0
      カンマ数 = カンマ数 + 1
    ElseIf Mid(ReadDete, i, 1) = Chr(34) And WクォFlg = 0 Then
      WクォFlg = 1
    ElseIf Mid(ReadDete, i, 1) = Chr(34) And WクォFlg = 1 Then
      WクォFlg = 2
    ElseIf Mid(ReadDete, i, 1) = "," And WクォFlg = 2 Then
      WクォFlg = 0
      カンマ数 = カンマ数 + 1
    ElseIf i = Len(ReadDete) Then
      CNT = CNT + 1
      ReDim Preserve TBL(1 To CNT)
      TBL(CNT) = 1
    End If
  Next
  
  Range("B2").Resize(, カンマ数 + 1).Value = TBL
  
  STAdd = StartAddSet
  
  huhu = Range(STAdd).Row
  popo = (Range(STAdd).Row + DataCnt - 1)
  yuio = Cells.Rows.Count - (Range(STAdd).Row + DataCnt - 1)
  
  STRow = 1
  If DataCnt > Cells.Rows.Count * 2 Then
    MsgBox DataCnt & "以上は、このマクロでは無理です。"
    End
  ElseIf Cells.Rows.Count - (Range(STAdd).Row + DataCnt - 1) >= 0 Then
    LPC = 1
  Else
    Ag = (Range(STAdd).Row + DataCnt) - Rows.Count
    LPC = 2
  End If
   
  'End
  
  For i = 1 To LPC
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & OpenFile, _
       Destination:=Range(STAdd))
      .AdjustColumnWidth = False
      .TextFilePlatform = xlWindows
      .TextFileStartRow = STRow
      .TextFileParseType = xlDelimited
      .TextFileTextQualifier = xlTextQualifierDoubleQuote
      .TextFileConsecutiveDelimiter = False
      .TextFileTabDelimiter = True
      .TextFileSemicolonDelimiter = False
      .TextFileCommaDelimiter = True
      .TextFileSpaceDelimiter = False
      .TextFileColumnDataTypes = TBL
      .Refresh BackgroundQuery:=False
    End With
    If LPC = 2 And i = 1 Then
      '3537
      'STRow = DataCnt - (Range(STAdd).Row + DataCnt - 1) - Rows.Count
      STRow = Rows.Count - Range(STAdd).Row + 1
      AcShNam = ActiveSheet.Name
      Worksheets.Add(After:=ActiveSheet).Name = AcShNam & "-2"
      Application.DisplayAlerts = False
    End If
  Next
  Application.DisplayAlerts = True
  Erase TBL
  MsgBox Format(Now() - Stime, "hh:mm:ss") & vbCrLf & OpenFile
  End
End Sub

Private Function StartAddSet() As String
  Dim StartAdd As Range
  On Error Resume Next
  Set StartAdd = Application.InputBox(Prompt:="書込む最初のセルをクリックして下さい。", _
             Title:="書込み位置の選択", Default:=ActiveCell.Address, Type:=8)
  If StartAdd Is Nothing Then
    Set StartAdd = Nothing
    End
  ElseIf StartAdd.Count <> 1 Then
    Set StartAdd = Nothing
    End
  Else
    StartAddSet = StartAdd.Address(0, 0)
  End If
  On Error GoTo 0
  Set StartAdd = Nothing
End Function

0 hits

【6639】テキストファイルのインポート こうき 03/7/16(水) 15:14 質問
【6640】Re:テキストファイルのインポート Jaka 03/7/16(水) 15:54 回答
【6641】Re:テキストファイルのインポート こうき 03/7/16(水) 16:57 質問
【6642】Re:テキストファイルのインポート Jaka 03/7/16(水) 17:37 回答
【6643】Re:テキストファイルのインポート ichinose 03/7/16(水) 18:24 発言
【6644】ちょっと、訂正 ichinose 03/7/16(水) 18:34 発言
【6646】Re:ちょっと、訂正 こうき 03/7/17(木) 9:26 お礼
【6645】ありがとうございます こうき 03/7/17(木) 9:24 お礼

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