ExcelVBAについて質問です。


[取込]ボタンを押下すると自動で下記動作を実行するVBAについて
教えて頂けますと大変助かります。

[取込]ボタン(オートシェイプ四角)←マクロの登録

1)セル(固定 例:C19)を選択
2)データ>外部データの取込み>データの取込みを選択
3)[データファイルの選択]画面にて対象ファイル(tsv)を選択
  ※tsvファイルはタブ区切り
4)[テキストファイルウィザード 1/3] デフォルトのまま[次へ]
  ※データ形式は、カンマやタブなどの区切り・・
5)[テキストファイルウィザード 2/3] デフォルトのまま[次へ]
  ※区切り文字はタブ、文字列の引用符は"
6)[テキストファイルウィザード 2/3] ★データ形式を変更
  11列目→文字列
  12列目→文字列
  13列目→文字列
  ※日付を[2010/01/28 17:00:00]←このままで取込みたい為
  [完了]を押下
7)取込み後、自動保存

★他の動作
・セル(固定 例:C2)に取込んだファイル名を表示
・上記で取込みをすると、自動で列を調整するため
 取込む前の状態(Excel)の列幅は変えないようにしたい。(重要)

ご教示頂けますと大変助かります。
以上 宜しくお願い致します。

回答の条件
  • 1人2回まで
  • 登録:
  • 終了:2010/05/27 14:42:43
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:SALINGER No.1

回答回数3454ベストアンサー獲得回数969

ポイント100pt

こんな感じでどうでしょうか。

Sub 四角形1_Click()
    Const strRange As String = "C9"     '固定セルの指定
    Const strTitle As String = "C2"     'ファイル名セルの指定
    Dim vntFileName As Variant
    
    vntFileName = Application.GetOpenFilename( _
             FileFilter:="tsvファイル(*.tsv),*.tsv" _
           , FilterIndex:=1 _
           , Title:="tsvファイルを選択してください" _
           , MultiSelect:=False)

    If vntFileName = False Then Exit Sub
       
    ActiveSheet.Range(strRange).Select

    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & vntFileName, Destination:=Range(strRange))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    ActiveSheet.Range(strTitle).Value = Mid(vntFileName, InStrRev(vntFileName, "\") + 1)
    
    ThisWorkbook.Save
End Sub
id:hananeko_0

完璧な動作でした!

大変助かりました。ありがとうございました!

皆、感動しております。

2010/05/27 14:41:51
  • id:SALINGER
    TextFileColumnDataTypesの行の最後の「,1」は必要ないです。
    マクロの自動記録で14列のデータで試したので付いたものです。
    無ければ自動的に1(標準)になるので。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません