Excel VBA質問箱 IV

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

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


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

【14159】エクセルVBAの記述 さる 04/5/22(土) 12:18 質問[未読]
【14161】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 12:49 回答[未読]
【14164】Re:エクセルVBAの記述 さる 04/5/22(土) 13:11 質問[未読]
【14178】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 15:15 回答[未読]
【14179】Re:エクセルVBAの記述 さる 04/5/22(土) 15:20 質問[未読]
【14180】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 15:47 発言[未読]
【14181】Re:エクセルVBAの記述 さる 04/5/22(土) 16:14 質問[未読]
【14182】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 16:23 回答[未読]
【14183】Re:エクセルVBAの記述 さる 04/5/22(土) 16:31 質問[未読]
【14184】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 16:56 発言[未読]
【14185】Re:エクセルVBAの記述 さる 04/5/22(土) 17:38 質問[未読]
【14190】Re:エクセルVBAの記述 Hirofumi 04/5/22(土) 21:06 回答[未読]
【14188】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 18:35 発言[未読]

【14159】エクセルVBAの記述
質問  さる  - 04/5/22(土) 12:18 -

引用なし
パスワード
   こんにちは。
Win2000でEXCEL2000を使用しています。
少し説明しにくいのですが、分かる方ご教授頂けないでしょうか?
エクセルVBAを使いCSVをエクセルで自動保存させようとしています。
VBAは初めてに近いので全然分からないんです…
VBAの流れは
1.元のエクセルファイル(ここではtest.xlsとします)を開く(Sheet1に参照するデータが入っている)
2.マクロを実行する(この次からマクロで自動的に実行する)
3.CSVファイル(A.csv)を開き、test.xlsのsheet2にコピーする。
4.今日の日付をファイル名の最後につけデスクトップに保存する(本日でしたらtest0522.xlsになる)
5.可能でしたら、開いているエクセルのファイルを全て閉じる
現在スクリプトを

Sub CSV読込み()
'
' CSV読込み Macro

'
ChDir "C:\○○\csv"
Workbooks.Open Filename:= _
"C:\○○\csv\A.CSV"
Cells.Select
Selection.Copy
Windows("test.xls").Activate
Sheets("Sheet2").Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\○\デスクトップ\test040522.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
End Sub

としています。CSVを開いて名前を付けて保存するのは分かったのですがそれ以外がわかりません。どうかよろしくお願いします。
VBAの解説をしているよいサイトなどあったらあわせて教えていただけないでしょうか?
分が長く申し訳ございませんが、よろしくお願いします。

【14161】Re:エクセルVBAの記述
回答  かみちゃん  - 04/5/22(土) 12:49 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>としています。CSVを開いて名前を付けて保存するのは分かったのですがそれ以外がわかりません。どうかよろしくお願いします。

「それ以外」というのは、次のうちのどれでしょうか?

>3.CSVファイル(A.csv)を開き、test.xlsのsheet2にコピーする。
>4.今日の日付をファイル名の最後につけデスクトップに保存する(本日でしたらtest0522.xlsになる)
>5.可能でしたら、開いているエクセルのファイルを全て閉じる

4.について
 ActiveWorkbook.SaveAs Filename:= _
  "C:\○\デスクトップ\" & "test" & Format(Date,"yymmdd") & ".xls",  FileFormat:= _

5.について
 Workbooks.Close です。
 次のURLのサンプル4を参照してください。
 http://www2.moug.net/cgi-bin/technic.cgi?exvba+TI06010050

>VBAの解説をしているよいサイトなどあったらあわせて教えていただけないでしょうか?

この質問掲示板で、質問されるのもいいと思います。
また、以下のURLも参考になるかと思います。
http://www2.cty-net.ne.jp/~hidenori/vba/index.html
http://www6.plala.or.jp/MilkHouse/menu.html
http://www2.moug.net/cgi-bin/technic.cgi?exvba+IC

【14164】Re:エクセルVBAの記述
質問  さる  - 04/5/22(土) 13:11 -

引用なし
パスワード
   ▼かみちゃん さん:

ありがとうございます。

>4.について
> ActiveWorkbook.SaveAs Filename:= _
>  "C:\○\デスクトップ\" & "test" & Format(Date,"yymmdd") & ".xls",  FileFormat:= _
>
できました。ありがとうございます。他のサイトがあったので調べていてDate関数を使えばいけるかなぁ〜っと思っていたら調度ご回答をいただけて助かりました。

>5.について
> Workbooks.Close です。
> 次のURLのサンプル4を参照してください。
> http://www2.moug.net/cgi-bin/technic.cgi?exvba+TI06010050

ありがとうございます。できました。

>>VBAの解説をしているよいサイトなどあったらあわせて教えていただけないでしょうか?
>
>この質問掲示板で、質問されるのもいいと思います。
>また、以下のURLも参考になるかと思います。
>http://www2.cty-net.ne.jp/~hidenori/vba/index.html
>http://www6.plala.or.jp/MilkHouse/menu.html
>http://www2.moug.net/cgi-bin/technic.cgi?exvba+IC

参考にさせていただきます。

甘えさせて追加で聞きたいことがあるのですが…
1.エクセルのこのファイルtest.xlsを開いた時に自動でマクロを実行する。
2.ワークシートを閉じる時にエクセル自体を終了することはできますか?

何度もすみませんが、よろしくお願いします。

【14178】Re:エクセルVBAの記述
回答  かみちゃん  - 04/5/22(土) 15:15 -

引用なし
パスワード
   >1.エクセルのこのファイルtest.xlsを開いた時に自動でマクロを実行する。

Auto_Openプロシージャに記述すると、そのブックを開くと自動的に実行されます。
http://www.asahi-net.or.jp/~zn3y-ngi/YNxv91.html

>2.ワークシートを閉じる時にエクセル自体を終了することはできますか?

Excelを終了させるにはQuitメソッドを使用します。
http://www2.moug.net/cgi-bin/technic.cgi?exvba+TI15010079

【14179】Re:エクセルVBAの記述
質問  さる  - 04/5/22(土) 15:20 -

引用なし
パスワード
   ▼かみちゃん さん:
>>1.エクセルのこのファイルtest.xlsを開いた時に自動でマクロを実行する。
>>2.ワークシートを閉じる時にエクセル自体を終了することはできますか?

何度もありがとうございます。
こちらは解決したのですが、新たな問題が1点出てきました。
AUTOでスタートさせそのままマクロで自動で作ったエクセルのファイルですが、開くともう一度マクロを実行させるみたいなのですが、
この新しく作ったファイルはマクロを実行させないっと言う風にはできますか?
ホントに何度も申し訳ございません…

【14180】Re:エクセルVBAの記述
発言  かみちゃん  - 04/5/22(土) 15:47 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>AUTOでスタートさせそのままマクロで自動で作ったエクセルのファイルですが、開くともう一度マクロを実行させるみたいなのですが、
>この新しく作ったファイルはマクロを実行させないっと言う風にはできますか?

元のファイルは、test.xlsで、シートコピーしたあとに、別名で保存すると、test.xlsに入っていたマクロ(Auto_Openを含めて)も別名のファイルに含まれます。
したがって、そのファイルを開くと、Auto_Open他、各マクロが実行されます。
もしかして、別名で保存するファイルには、マクロは含ませたくないということなのでしょうか?

【14181】Re:エクセルVBAの記述
質問  さる  - 04/5/22(土) 16:14 -

引用なし
パスワード
   ▼かみちゃん さん:

何回もありがとうございます。
まさしくその通りなのですが、無理ですか?
またまたすみませんが、【実行エラー'9' インデックスが有効範囲にありません】
とはどういうエラーなんでしょうか?

【14182】Re:エクセルVBAの記述
回答  かみちゃん  - 04/5/22(土) 16:23 -

引用なし
パスワード
   こんにちは。かみちゃん です。
>まさしくその通りなのですが、無理ですか?

「別名で保存するファイルには、マクロは含ませたくない」というこどてあれば、CSVファイルを開いた時点で、そのCSVファイルに、test.xlsのSheet1をコピーして、Excel形式で保存するように変えたらいかがですか?
そうすると、マクロは含まれません。

>またまたすみませんが、【実行エラー'9' インデックスが有効範囲にありません】
>とはどういうエラーなんでしょうか?

どこで起きているのかがわかりませんが、シートがないとか、セルがないとか、いろいろです。

【14183】Re:エクセルVBAの記述
質問  さる  - 04/5/22(土) 16:31 -

引用なし
パスワード
   >「別名で保存するファイルには、マクロは含ませたくない」というこどてあれば、CSVファイルを開いた時点で、そのCSVファイルに、test.xlsのSheet1をコピーして、Excel形式で保存するように変えたらいかがですか?
>そうすると、マクロは含まれません。
>
ほんとに何度もありがとうございます。
かみちゃんさんのおかげさまで大変助かります。
アドバイスのようにしたいのですが、
やろうとしていることがCSVファイルを6個読込みその各々のCSVを
Sheet1〜6にコピーします。そのコピーした値をSheet7で参照して使いたいので
どうしても無理なんです…。
CSVをエクセル形式で保存するように変えるしか方法がないんでしょうか?
だとしたら諦めます。
ホントに何度もすみません…。

【14184】Re:エクセルVBAの記述
発言  かみちゃん E-MAIL  - 04/5/22(土) 16:56 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>やろうとしていることがCSVファイルを6個読込みその各々のCSVを
>Sheet1〜6にコピーします。そのコピーした値をSheet7で参照して使いたいので

すみません、なさりたいことがわからなくなってきたのですが、
元々のExcelファイルには、Sheet1からSheet7があって、各CSVからSheet1〜Sheet6にコピーします。(最初CSVファイルは、Sheet2にコピーするようなことをおっしゃっていたような・・・)
ここで、別名で保存しようとしているのですが、この間に、test.xlsのSheet1からSheet7を新しいブックにコピーして、その新しいブックを名前を付けて保存すればいかがですか?

あきらめることはないと思いますよ。

【14185】Re:エクセルVBAの記述
質問  さる WEB  - 04/5/22(土) 17:38 -

引用なし
パスワード
   すみません。
なんか私も訳がわからなくなってきたので整理してみます…。
まず、テスト1.xlsにSheet1〜7まであります。
そしてSheet2〜7までにCSVファイルの1〜6までをコピーします。
その後ファイル名を付けて保存しようとしています。
できれば、マクロを削除したいと言う訳です。
マクロの削除はともかくとして、
他のPCで実行させようとしたら実行してくれません。
始めに作る時に【個人用マクロブック】に保存にしたのがいけなかったのかと思い
作業中のブックに指定をして作ったのですがダメでした…
すみませんが、ファイルをアップしますので、一度見てもらえませんか?
ファイル名が少し違いますが,やろうとしていることは同じです。
よろしくお願いします。

【14188】Re:エクセルVBAの記述
発言  かみちゃん E-MAIL  - 04/5/22(土) 18:35 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>まず、テスト1.xlsにSheet1〜7まであります。
>そしてSheet2〜7までにCSVファイルの1〜6までをコピーします。
>その後ファイル名を付けて保存しようとしています。
>できれば、マクロを削除したいと言う訳です。

マクロを削除するのではなくて、全シートを新規ブックにコピーしてはいけないのでしょうか?発想の転換です。

>他のPCで実行させようとしたら実行してくれません。

とりあえず、アップしていただいたファイルを見させていただきました。
Auto_Openマクロに、
Workbooks.Open Filename:= "xxxxx.xls"
とExcelファイルを開く記述がありますが、これは必要ないのではないでしょうか?

>すみませんが、ファイルをアップしますので、一度見てもらえませんか?

見させていただいたファイルですが、このCSVファイル、掲示板にアップしてよかったのですか?
ファイルは、メールでいただいてもよかったのですが・・・

【14190】Re:エクセルVBAの記述
回答  Hirofumi E-MAIL  - 04/5/22(土) 21:06 -

引用なし
パスワード
   チョット長くなるけど(大分かな?)こんな事なのかな?
test.xlsのマクロを削除するのでは無く、
マクロの有るBookからtest.xlsをOpenし、このBookにシートを追加して
其処に、Csvファイルを読み込み、最後にファイル名に日付を付加してSaveします
尚、test.xlsは、シートを追加するのでSheet1だけにして下さい
また、Csvファイルは、GetOpenFileNameのダイアログを出して複数選択する様にして有りますが
フォルダを指定しておいて、其処のCsvファイルを読む様にする場合
「「ファイルを開く」ダイアログを複数選択で表示」以下の3行を削除して
「指定フォルダ内の".csv"ファイルを全て開く場合」を活かして下さい

以下をマクロを組み込むBookの標準モジュールに記述して下さい

Option Explicit

Public Sub CsvDataRead()

  Dim i As Long
  Dim vntFileNames As Variant
  Dim lngWriteRow As Long
  Dim wksWrite As Worksheet
  Dim strPath As String
  Dim strSheetName As String
  Dim strSavePath As String
  
  'Csvファイルを読み込むBookをOpen
  Workbooks.Open ThisWorkbook.Path & "\" & "test.xls"
'  Workbooks.Open "C:\○\デスクトップ\" & "test.xls"
  'BookをSaveするフォルダを取得
  strSavePath = ActiveWorkbook.Path
  
  'Csvファイルの有るフォルダを指定
  strPath = ActiveWorkbook.Path
'  strPath = "C:\○○\csv"
  
  'ファイル名の範囲指定で開く場合
  '「ファイルを開く」ダイアログを複数選択で表示
  If Not GetReadFile(vntFileNames, strPath, True) Then
    Exit Sub
  End If
  
'  '指定フォルダ内の".csv"ファイルを全て開く場合
'  If Not SearchFiles(vntFileNames, strPath, "k*.csv") Then
'    Exit Sub
'  End If
  
'  Application.ScreenUpdating = False
    
  '複数選択されたファイルをシートに出力
  For i = 1 To UBound(vntFileNames)
    'シート名を作成
    strSheetName _
      = GetFileName(vntFileNames(i))
    strSheetName _
      = GetSheetName(strSheetName)
    'アクティブBookにシートを追加
    With ActiveWorkbook.Worksheets
      '出力シートを設定
      Set wksWrite _
        = .Add(After:=Worksheets(.Count))
    End With
    With wksWrite
      .Columns("A:E").NumberFormat = "@"
      'シート名を変更
      .Name = strSheetName
    End With
    '出力する先頭行を設定
    lngWriteRow = 1
    'CSVを書き込み
    CSVRead vntFileNames(i), _
          wksWrite, lngWriteRow, 1
    wksWrite.Columns.AutoFit
  Next i
  Set wksWrite = Nothing

  '"test.xls"に日付を付けてSave
  With ActiveWorkbook
    .SaveAs GetFileName(ActiveWorkbook.Name) _
          & Format(Date, "mmdd") & ".xls"
    .Close
  End With
  
'  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Sub CSVRead(ByVal strFileName As String, _
              ByVal wksWrite As Worksheet, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1)
  
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  
  '空きファイルバファ番号を取得
  dfn = FreeFile
  'ファイルをInputモードで開く
  Open strFileName For Input As dfn
  
  'ファイルエンドまで繰り返し
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'レコードをフィールドに分割
    vntField = SplitCsv(strBuff, ",")
        
    '指定シートの指定列、行について
    With wksWrite.Cells(lngRow, lngCol)
      '結果配列を代入
      .Offset.Resize(, UBound(vntField) + 1) = vntField
    End With
    '書き込み行を更新
    lngRow = lngRow + 1
  Loop
  
  'ファイルをClose
  Close #dfn
  
End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As String
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = ""
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

Private Function GetReadFile(vntFileNames As Variant, _
          Optional strFilePath As String, _
          Optional blnMulti As Boolean = False) As Boolean

  Dim strFilter As String

  strFilter = "CSV File (*.csv),*.csv," _
        & "全て (*.*),*.*"
  If strFilePath <> "" Then
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  If vntFileNames <> "" Then
    SendKeys vntFileNames, False
  End If
  vntFileNames _
    = Application.GetOpenFilename(strFilter, 1, , , blnMulti)
  If Not VarType(vntFileNames) = vbBoolean Then
    GetReadFile = True
  End If
  
End Function

Private Function SearchFiles(vntFileNames As Variant, _
            strFilePath As String, _
            strFile As String) As Variant

  Dim i As Long
  Dim lngEnd As Long
  
  With Application.FileSearch
    .LookIn = strFilePath
    .FileName = strFile
    If .Execute(SortBy:=msoSortByFileName, _
        SortOrder:=msoSortOrderAscending) > 0 Then
      If VarType(vntFileNames) = vbEmpty Then
        lngEnd = 0
        ReDim vntFileNames(1 To .FoundFiles.Count)
      Else
        lngEnd = UBound(vntFileNames)
        ReDim Preserve _
          vntFileNames(1 To lngEnd + .FoundFiles.Count)
      End If
      For i = 1 To .FoundFiles.Count
        vntFileNames(lngEnd + i) = .FoundFiles(i)
      Next i
      SearchFiles = True
    End If
  End With
        
End Function

Private Function GetSheetName(ByVal strName As String) As String

  Dim i As Long
  Dim lngPos As Long
  Dim lngNumb As Long
  Dim lngTmpNumb As Long
  Dim strSName As String
  
  lngPos = Len(strName) + 1
  lngNumb = -1
  With ActiveWorkbook
    For i = 1 To .Worksheets.Count
      strSName = .Worksheets(i).Name
      If strSName Like strName & "*" Then
        Select Case Mid(strSName, lngPos, 1)
          Case ""
            lngTmpNumb = 0
          Case "("
            lngTmpNumb _
                = InStr(1, strSName, ")", _
                        vbBinaryCompare)
            If lngTmpNumb > 0 Then
              lngTmpNumb _
                = Val(Mid(strSName, lngPos + 1, _
                    lngTmpNumb - lngPos - 1))
            Else
              lngTmpNumb _
                = Val(Mid(strSName, lngPos + 1))
            End If
          Case Else
            lngTmpNumb = -1
        End Select
        If lngNumb < lngTmpNumb Then
          lngNumb = lngTmpNumb
        End If
      End If
    Next i
  End With
  
  If lngNumb = -1 Then
    GetSheetName = strName
  Else
    GetSheetName = strName & "(" & (lngNumb + 1) & ")"
  End If

End Function

Private Function GetFileName(ByVal strName As String) As String

'  ファイル名をPathから分離

  Dim i As Long
  Dim lngPos As Long
  
  i = 0
  lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Loop
  strName = Mid(strName, i + 1)
  i = 1
  lngPos = InStr(i, strName, ".", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, ".", vbBinaryCompare)
  Loop
  GetFileName = Left(strName, i - 1)
  
End Function

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