| |
>これだと新しいファイルが開くのですが、
開きません。ファイルのフルパスを取得だけです。
現在クエリが使える環境でないので（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
|
|
Jaka
- 03/7/16(水) 17:37 -
