| |
最近と言うか、ここ数年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
|
|
Jaka
- 11/7/27(水) 15:41 -
