Excel VBA質問箱 IV

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

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


10556 / 13646 ツリー ←次へ | 前へ→

【21120】Excelにcsvファイル貼り付け時の処理 Aiz 05/1/12(水) 15:16 質問[未読]
【21121】Re:Excelにcsvファイル貼り付け時の処理 IROC 05/1/12(水) 15:23 回答[未読]
【21126】Re:Excelにcsvファイル貼り付け時の処理 Aiz 05/1/12(水) 16:42 質問[未読]
【21133】Re:Excelにcsvファイル貼り付け時の処理 IROC 05/1/12(水) 18:26 回答[未読]
【21148】Re:Excelにcsvファイル貼り付け時の処理 Jaka 05/1/13(木) 11:51 回答[未読]
【21165】Re:Excelにcsvファイル貼り付け時の処理 Aiz 05/1/13(木) 17:11 お礼[未読]

【21120】Excelにcsvファイル貼り付け時の処理
質問  Aiz  - 05/1/12(水) 15:16 -

引用なし
パスワード
   csvファイルを読み込んでExcelのファイルに貼り付ける処理で、csvファイルに書かれているデータを正しくExcelに出力できません。
読み込むcsvファイルの例はこちら↓
(1)    (2)     (3)      (4)              (5)
4    データ    82     デガ出スキャンニング   1200
4    データ    754    10MB追加         120000
4    データ    853    20MB追加        110000

読み込みが(4)の"10MB追加"というところで、Excel出力時には"10"だけしか出力されません。
これを次の"20MB追加"みたいに数字を全角にしてやると出力されるのですが、"10MB追加"のように半角でも表示させたいのです。

Excelファイルのマクロはこちら↓

'CSVファイルの内容を貼り付ける
Const csv2 = "ボディ部.csv"

Sub Auto_Open()
  Dim fname As String
  Dim fno As Integer
  Dim col(0 To 4) As Variant
  Dim i As Integer
  
  'ファイル名
  fname2 = ActiveWorkbook.Path & "\" & csv2
  
  'CSVファイルの内容を貼り付ける(ボディ部)
  fno = FreeFile
  On Error GoTo file_not_found
  Open fname2 For Input As #fno
  On Error GoTo 0
  l = 4
  Do Until EOF(fno)    ’-----ココの処理がおかしいと思われる。
    Input #fno, col(0), col(1), col(2), col(3), col(4)
    MsgBox col(3)
    l = l + 1
    Range(Cells(l, 2), Cells(l, 6)).Value = col
  Loop
  Close #fno
  
  'オートフォーマット
  Cells(4, 2).CurrentRegion.AutoFormat _
    Format:=xlRangeAutoFormatLocalFormat3, _
    Number:=False, _
    Font:=False, _
    Alignment:=False
  
  'CSVファイルを削除する
  'Kill fname2
  
  Exit Sub
  
file_not_found:
  MsgBox "CSVファイルが見つかりません", vbCritical + vbOKOnly, "システムエラー"

End Sub

よろしくお願いします。

【21121】Re:Excelにcsvファイル貼り付け時の処理
回答  IROC  - 05/1/12(水) 15:23 -

引用なし
パスワード
   EXCELのバージョンが分かりませんが、
データ→外部データの取り込み→テキストファイルのインポート
を使っては如何でしょうか?

【21126】Re:Excelにcsvファイル貼り付け時の処理
質問  Aiz  - 05/1/12(水) 16:42 -

引用なし
パスワード
   返信ありがとうございます。
csvファイルへの入力はフォーマットの決まったExcelファイルを開いたときに自動で読み込むようにしないといけません。
それで返信のあったように外部データ取り込みでやるとうまくいきました。
この外部取り込みをマクロでやろうとしています。
外部取り込みをマクロで登録して、ファイルを読む場所を変更しようとしたのですが、アプリケーション定義またはオブジェクトの定義エラーがでてしまいます。
よろしくお願いします。
ちなみにExcelは2002です。

マクロ修正前↓

fname2 = ActiveWorkbook.Path & "\" & csv2

'CSVファイルの内容を貼り付ける(ボディ部)
  fno = FreeFile
  On Error GoTo file_not_found
  Open fname2 For Input As #fno
  On Error GoTo 0

With ActiveSheet.QueryTables.Add(Connection:= _
    "TEXT;C:\Documents and Settings\****\My Documents\マスタ出力\ボディ部.csv", _
    Destination:=Range("B5"))  '↑ここのパスを直でなく変数にしたい
    .Name = "ボディ部"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 932
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
  End With


修正後マクロ↓
With ActiveSheet.QueryTables.Add(Connection:= _
    fname2, Destination:=Range("B5"))  '←ここを修正したい。
    .Name = "ボディ部"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 932
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
  End With

【21133】Re:Excelにcsvファイル貼り付け時の処理
回答  IROC  - 05/1/12(水) 18:26 -

引用なし
パスワード
   そのまま変数にすることは可能です。
私には変数の中身が分かりませんが、
"TEXT;" などを省略してはだめですよ。

【21148】Re:Excelにcsvファイル貼り付け時の処理
回答  Jaka  - 05/1/13(木) 11:51 -

引用なし
パスワード
   こんにちは。

>読み込みが(4)の"10MB追加"というところで、Excel出力時には"10"だけしか出力されません。
Inputで読み込んでVariant変数に格納すると、こうなるとは思ってもいませんでした。
エクセルのいらぬ処理って言うか、val変換してその結果を判定してもろもろしているみたいな感じですね?
勉強になりました。
簡単には文字型(String)に格納すればうまくいくようですが、数値として代入できないのでセルに書き込んだ後に数値変換させるコードを追加するのもなんだと思いまして考えてみ結果、一旦String型で受けてVariant型に入れなおす事で何とかうまくいくみたいでした。
下記コードは、テスト時のままですから使う環境に合わせて変更してください。

Sub ttAuto_Open()
  Dim fname As String
  Dim fno As Integer
  Dim col(0 To 4) As Variant
  Dim i As Integer
  Dim sts As String
 
  'ファイル名
  'fname2 = ActiveWorkbook.Path & "\" & csv2
  fname2 = Application.GetOpenFilename("Excelファイル (*.csv;*.txt), *.csv;*.txt")
  If fname2 = "False" Then
    End
  End If

  'CSVファイルの内容を貼り付ける(ボディ部)
  fno = FreeFile
  On Error GoTo file_not_found
  Open fname2 For Input As #fno
  On Error GoTo 0
  l = 4
  Do Until EOF(fno)    '-----ココの処理がおかしいと思われる。
    'Input #fno, col(0), col(1), col(2), col(3), col(4)
    For i = 0 To 4
      Input #fno, sts
      col(i) = sts
    Next
    l = l + 1
    Range(Cells(l, 2), Cells(l, 6)).Value = col
  Loop
  Close #fno
 
  'オートフォーマット
  Cells(4, 2).CurrentRegion.AutoFormat _
    Format:=xlRangeAutoFormatLocalFormat3, _
    Number:=False, _
    Font:=False, _
    Alignment:=False
 
  'CSVファイルを削除する
  'Kill fname2
  Exit Sub
 
file_not_found:
  MsgBox "CSVファイルが見つかりません", vbCritical + vbOKOnly, "システムエラー"

End Sub

【21165】Re:Excelにcsvファイル貼り付け時の処理
お礼  Aiz  - 05/1/13(木) 17:11 -

引用なし
パスワード
   無事問題が解決しました!
ありがとうございました。また何かありましたらよろしくお願いします。

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