| |
Jakaさん
ご回答ありがとうございます。
早速実行してみましたら、一列にズラッと出てきました。
これでも規則正しければ使えるかなと思い元データと照らし合わせてみたのですが、表示されない数字などがあり、残念ながら解決できませんでした。
でも大変感謝しております。本当にありがとうございました。
▼Jaka さん：
>最近と言うか、ここ数年Macでエクセルを触っていないので・・・・。
>Macバイナリーが原因か解らんけど、除去するアプリ。
>
>ht tp://www.vector.co.jp/soft/win95/util/se149423.html
>ht tp://ww1.tiki.ne.jp/~swinepal/sunyansoft/support/macbn/macbn_sp.html
>
>ここのAppleさんなら、原因が解るのかも？
>ht tp://excelfactory.net/excelboard/excelvba/excel.cgi
>
>おまけ、ここがVBA研究所と名乗っていたころに書いた物。何年前だ？
>当時のまま今でも使ったりしてます。
>
>
>Option Base 1
>
>Sub aaaa()
> Dim シート名 As String, 基シート名 As String, 処理CNT As Long, CSV全データ行数 As Long
> Dim 書始め行 As Long, 増シート数 As Integer, 行 As Long, 列位置 As Integer
> Dim TBL() As String, カンマ数 As Integer, TBL行数 As Long, TBL行CNT As Long, 拡張子 As String
> Dim ReadData As String, 設定行 As Long, 設定列 As Long, バーお知らせ As String
> Dim 基本TBL行数 As Long, 使用TBL行数 As Long, 終了flg As Integer, 改シート行flg As Integer
> Dim 書込み最終行設定 As Long, 書込み有効残数 As Long, シート最終行入力 As String, 追加枚数 As Integer
> Dim 振分け As Variant, 振分け2 As Variant, STime As Variant, ETime As Variant
> Dim I As Long, WクォFlg As Byte, DoEvCnt As Long
>
> 基シート名 = ActiveSheet.Name
> シート名 = 基シート名: 増シート数 = 0: 改シート行flg = 0
> CSV全データ行数 = 0: バーお知らせ = "行目から ": 終了flg = 0: カンマ数 = 0: DoEvCnt = 0
> 基本TBL行数 = 500: TBL行CNT = 0: 処理CNT = 0: 改シートflg = 0: WクォFlg = 0
>
> 'On Error Resume Next
> オープンファイル = Application.GetOpenFilename("Excelファイル (*.csv;*.txt), *.csv;*.txt")
> If オープンファイル <> False Then
> 拡張子 = StrConv(Right(オープンファイル, 3), vbUpperCase)
> Open オープンファイル For Input As #1
> Else
> End
> End If
>
> '書込み形式入力
> Line Input #1, ReadData
> 振分け = MsgBox(拡張子 & "ファイルをカンマ区切りでセルに振分けますか？" & vbCrLf & vbCrLf & _
> "振分けずに1列に読込むなら「いいえ」を。" & vbCrLf & vbCrLf & _
> "中止するならキャンセルを選択してください。", vbQuestion + vbYesNoCancel, 拡張子 & _
> "ファイル読込形式")
> If 振分け = vbYes Then
> For I = 1 To Len(ReadData)
> If Mid(ReadData, I, 1) = "," And WクォFlg = 0 Then
> カンマ数 = カンマ数 + 1
> ElseIf Mid(ReadData, I, 1) = Chr(34) And WクォFlg = 0 Then
> WクォFlg = 1
> ElseIf Mid(ReadData, I, 1) = Chr(34) And WクォFlg = 1 Then
> WクォFlg = 0
> End If
> Next
> If カンマ数 = 0 Then
> 振分け2 = MsgBox("１行目データを見た所、区切りのカンマが全くありません。" & Chr(13) & _
> "強行しますか？", vbExclamation + vbYesNo, "カンマエラー")
> If 振分け2 = vbNo Then
> Close #1
> End
> End If
> ElseIf カンマ数 > 100 Then
> 基本TBL行数 = 100
> ElseIf カンマ数 > 50 Then
> 基本TBL行数 = 200
> End If
> ElseIf 振分け = vbNo Then
> 基本TBL行数 = 15000
> Else
> Close #1
> End
> End If
> Close #1
> ReadData = Empty
>
> 'CSV全データ行数カウント。速いパソコン or データ量が少ないとカウントが速過ぎて見えない。
> Set myShape1 = ActiveSheet.Shapes.AddTextEffect(msoTextEffect11, _
> "現在、" & 拡張子 & "全データ行数を" & vbCrLf & "カウントしています。 ", _
> "ＭＳ ゴシック", 28, msoFalse, msoFalse, 120, 100)
> 'Application.DisplayStatusBar = True
> 'Application.StatusBar = 拡張子 & "全データ行数をカウントしています 。"
> DoEvents
> DoEvents
> Open オープンファイル For Input As #1
> Do Until EOF(1)
> Line Input #1, ReadData
> CSV全データ行数 = CSV全データ行数 + 1
> Loop
> Close #1
> 'Application.DisplayStatusBar = False
>
> 'Set TxStm = Fso.OpenTextFile(Filename:=オープンファイル, IOMode:=ForReading)
> 'Do Until TxStm.AtEndOfLine
> ' TxStm.SkipLine
> 'Loop
> 'CSV全データ行数 = TxStm.Line - 1
> 'Set TxStm = Nothing
>
> myShape1.Delete
> Set myShape1 = Nothing
> DoEvents
>
> 'シート最終行（改ページ行）入力
> 書込み最終行設定 = Cells(Rows.Count, 1).Row
> Do
> シート最終行入力 = Application.InputBox(Prompt:=拡張子 & "全データ行数は、" & CSV全データ行数 & "行有りました。" & _
> vbCrLf & vbCrLf & "書込み最終行（改ページ行）を入力して下さい。", _
> Title:="書込み最終行（改ページ行）入力", Default:=書込み最終行設定)
> If シート最終行入力 = "False" Then
> End
> ElseIf Not (IsNumeric(シート最終行入力)) Then
> MsgBox "数字を入力して下さい。", vbExclamation, "入力エラー"
> ElseIf シート最終行入力 < 1 Or シート最終行入力 > 書込み最終行設定 Then
> MsgBox "最終行（改ページ行）は、1〜" & 書込み最終行設定 & "の間までです。", vbExclamation, "入力エラー"
> Else
> 書込み最終行設定 = Int(シート最終行入力)
> Exit Do
> End If
> Loop
>
> Do
> Call 書込み開始位置設定(設定行, 設定列)
> If 設定行 > 書込み最終行設定 Then
> MsgBox "書込み最終行（改ページ行）" & "行より下行を" & vbCrLf & _
> "書込み開始行とすることはできません。", vbExclamation, "開始位置設定エラー"
> ElseIf CSV全データ行数 / (書込み最終行設定 - (設定行 - 1)) + Worksheets.Count - 1 > 50 Then
> 追加枚数 = CSV全データ行数 / (書込み最終行設定 - (設定行 - 1)) - 1
> 中止有無 = MsgBox("現在のシート枚数 " & Worksheets.Count & " 枚、追加されるシート枚数 " & 追加枚数 & " 枚。" & vbCrLf & _
> vbCrLf & "全シート枚数が50枚を超えます。" & vbCrLf & vbCrLf & "書き始め行と書込み最終行（改シート行）を設定を変えますか？" & _
> vbCrLf & vbCrLf & "見なおす場合は、一旦終了します。", vbExclamation + vbYesNo, "シート追加枚数警報")
> If 中止有無 = vbYes Then
> End
> Else
> Exit Do
> End If
> Else
> Exit Do
> End If
> Loop
> 書始め行 = 設定行
> 行 = 書始め行
> 書始め列 = 設定列
>
> '初期TBL行数設定
> 書込み有効残数 = 書込み最終行設定 - (書始め行 - 1)
> If 書込み有効残数 < 基本TBL行数 Then
> 基本TBL行数 = 書込み有効残数
> ElseIf CSV全データ行数 <= 基本TBL行数 Then
> 基本TBL行数 = CSV全データ行数
> 終了flg = 1
> End If
> TBL行数 = 基本TBL行数
> ReDim TBL(TBL行数, カンマ数 + 1)
>
> Application.DisplayStatusBar = True
> 'Application.ScreenUpdating = False
> Application.Calculation = xlManual
>
> STime = Now()
> Open オープンファイル For Input As #1
> Do Until EOF(1)
> 処理CNT = 処理CNT + 1
> TBL行CNT = TBL行CNT + 1
> 'Application.StatusBar = 拡張子 & "全データ " & CSV全データ行数 & "行中、" & Format(処理CNT, "000000") & "行目読込み中"
>
> 'セル列方向TBL転記
> If カンマ数 = 0 Then
> Line Input #1, TBL(TBL行CNT, カンマ数 + 1)
> 'TBL(TBL行CNT, カンマ数 + 1) = ReadData
> Else
> For I = 1 To カンマ数 + 1
> Input #1, TBL(TBL行CNT, I)
> Next
> End If
>
> If TBL行CNT = TBL行数 Or EOF(1) Then
> Application.StatusBar = 拡張子 & "全データ " & CSV全データ行数 & "行中、" & Format(処理CNT, "000000") & "行目読込み後、" & _
> シート名 & "に " & 行 & バーお知らせ & TBL行数 & "行の書込み中"
> With ActiveWorkbook.Worksheets(シート名).Range(Cells(行, 書始め列), Cells(行 + TBL行数 - 1, 書始め列 + カンマ数))
> .ClearContents
> .Value = TBL
> End With
> DoEvCnt = DoEvCnt + 1
> 'If DoEvCnt = 10 Then
> ' DoEvents
> ' DoEvCnt = 0
> 'End If
> DoEvents
> TBL行CNT = 0
> 行 = 行 + TBL行数
> 書込み有効残数 = 書込み有効残数 - TBL行数
> If 終了flg = 1 Then
> Exit Do
> End If
> If CSV全データ行数 - 処理CNT > 0 Then
> '改ページ
> If 書込み有効残数 = 0 Then
> Call TBL使用シート増(基シート名, シート名, 増シート数, 設定行, 設定列)
> DoEvents
> 行 = 書始め行
> 書込み有効残数 = 書込み最終行設定 - (書始め行 - 1)
> If CSV全データ行数 - 処理CNT < TBL行数 Then
> TBL行数 = CSV全データ行数 - 処理CNT
> Else
> TBL行数 = 基本TBL行数
> End If
> ElseIf 書込み有効残数 < TBL行数 Then
> TBL行数 = 書込み有効残数
> ElseIf CSV全データ行数 - 処理CNT < TBL行数 Then
> TBL行数 = CSV全データ行数 - 処理CNT
> Else
> TBL行数 = 基本TBL行数
> End If
> Else
> 終了flg = 1
> End If
> ReDim TBL(TBL行数, カンマ数 + 1)
> End If
> Loop
> Close #1
> Erase TBL
> ETime = Now()
> 'Application.ScreenUpdating = True
> Application.Calculation = xlAutomatic
> DoEvents
> Set myShape2 = ActiveSheet.Shapes.AddTextEffect(msoTextEffect11, _
> "処理終了しました ", "ＭＳ ゴシック", 48, msoFalse, msoFalse, 120, 100)
> Application.StatusBar = 拡張子 & "全データ " & CSV全データ行数 & "行中、" & Format(処理CNT, "000000") & "行の処理終了しました。"
> 'MsgBox "クリックして下さい。"
> 'MsgBoxだと位置を変えられないので。
> myShape2.Delete
> Set myShape2 = Nothing
> Application.DisplayStatusBar = False
> MsgBox "TBL行数" & 基本TBL行数 & vbCrLf & STime & "-" & ETime & "=" & Format(ETime - STime, "hh:mm:ss")
>End Sub
|
|
ぞう
- 11/7/27(水) 16:41 -
