Excel VBA質問箱 IV

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

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


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

【14281】CSVファイルを読み込む アスキー 04/5/25(火) 14:45 質問[未読]
【14284】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 15:20 回答[未読]
【14291】Re:CSVファイルを読み込む アスキー 04/5/25(火) 15:43 発言[未読]
【14294】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 15:51 発言[未読]
【14295】Re:CSVファイルを読み込む アスキー 04/5/25(火) 16:07 質問[未読]
【14299】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 16:26 回答[未読]
【14306】Re:CSVファイルを読み込む アスキー 04/5/25(火) 17:01 回答[未読]
【14307】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 17:11 回答[未読]
【14310】Re:CSVファイルを読み込む アスキー 04/5/25(火) 18:16 発言[未読]
【14312】Re:CSVファイルを読み込む [名前なし] 04/5/25(火) 18:59 回答[未読]
【14315】Re:CSVファイルを読み込む Hirofumi 04/5/25(火) 21:05 回答[未読]
【14317】Re:CSVファイルを読み込む Hirofumi 04/5/25(火) 21:44 回答[未読]
【14399】Re:CSVファイルを読み込む アスキー 04/5/28(金) 9:11 発言[未読]
【14517】Re:CSVファイルを読み込む アスキー 04/5/31(月) 17:50 質問[未読]
【14527】Re:CSVファイルを読み込む Hirofumi 04/5/31(月) 20:33 発言[未読]
【14536】Re:CSVファイルを読み込む アスキー 04/6/1(火) 1:33 質問[未読]
【14562】Re:CSVファイルを読み込む Hirofumi 04/6/1(火) 22:43 回答[未読]
【14573】Re:CSVファイルを読み込む アスキー 04/6/2(水) 10:11 質問[未読]
【14598】Re:CSVファイルを読み込む アスキー 04/6/2(水) 17:38 発言[未読]
【14603】Re:CSVファイルを読み込む Hirofumi 04/6/2(水) 21:11 回答[未読]
【14632】Re:CSVファイルを読み込む アスキー 04/6/3(木) 12:42 お礼[未読]

【14281】CSVファイルを読み込む
質問  アスキー  - 04/5/25(火) 14:45 -

引用なし
パスワード
   こんにちわ
Excel2002を使っています
素人で、ちょっとした処理をしたいのですが
全く理解できなかったので、知識のある方ご教授願います
以下説明文です

Data Folderというフォルダに、CSVファイルが毎日作っています
CSVファイル名は、20040501.csv 〜 20040531.csvとその日の日付になっています
それを元に、フォーマット.xlsというExcelファイルへ移したいのですが
1日のデータを、シート1枚に写し、1ヶ月分、シート31枚にデータを移したいのです
そこで、
実行ファイルという名のExcelのブックに作成という名のコマンドボタンを作成します
押すとオブジェクトが表示され
下記の様に入力できる項目と実行するボタンを作ります

_となっているところが入力できるTextBoxです

読み込み先フォルダ _______________

          _____年 __月 __日 〜 __日

                        実 行

ここで、読み込み先は、D:\Data Folder\として
年月日のところに
先ほどのcsvファイル名を入力するようにして
(2004年 05月 01日 〜 31日という具合に)
実行を押すと、フォーマット.xlsのシートへ移すという作業をさせたいのですが
素人ですので、どこから手をつけたらいいのかわかりません

どなたか、コピペするだけで、動くようなプログラムを作っていただけないでしょうか?

【14284】Re:CSVファイルを読み込む
回答  ちゃっぴ  - 04/5/25(火) 15:20 -

引用なし
パスワード
   他の板で似たような質問の際、作成したサンプルです。

ちょっと改造すれば出来るかと思います。
ミソは日付を日付型(Date型)へ変換一度変換することです。

Sub LoopSample()
  Dim datDataDate As Date
  Dim strFileName As String
  
  '日付型(Date型)へ変換
  datDataDate = CDate(YEAR1 & "/" & MONTH1 & "/" & DAY1)
  
  For i = 1 To DayCount 'DayCountまでループ(日指定)
    'ファイル名生成
    strFileName = PASS1 & Format$(datDataDate, "yyyymmdd") & ".xls
"
    
    'CSV読込処理を記述
    
    datDataDate = datDataDate + 1 '1日進む
  Next i
End Sub

後は、自分で考えましょう!

【14291】Re:CSVファイルを読み込む
発言  アスキー  - 04/5/25(火) 15:43 -

引用なし
パスワード
   >ちょっと改造すれば出来るかと思います。
>ミソは日付を日付型(Date型)へ変換一度変換することです。

返答はありがたいんですが素人なので言ってる意味がわかんないんですw

>後は、自分で考えましょう!

色んなサイト見て回っていますが、すぐにでも必要でして
ここの板を見てたところ、丁寧に返答されていたのでカキコしたのですがww

もう少し最後まで答えお願いできませんか? (´;ェ;`)ウゥ・・・

【14294】Re:CSVファイルを読み込む
発言  ちゃっぴ  - 04/5/25(火) 15:51 -

引用なし
パスワード
   アスキー さんへ
>色んなサイト見て回っていますが、すぐにでも必要でして
>ここの板を見てたところ、丁寧に返答されていたのでカキコしたのですがww

どこの板でも、プログラム作成丸投げというところはありませんよ。

サンプルを提示されたら、それについて調べてみるのが質問者の最低限のマナーです。

それでも、わからない点がありましたら、要点を明確にした上で質問いただければ、喜んで回答します。

> すぐにでも必要でして
ご自身で出来ないのでしたらきっぱり断るべきです。

【14295】Re:CSVファイルを読み込む
質問  アスキー  - 04/5/25(火) 16:07 -

引用なし
パスワード
   即答ありがとうございます
えっと
>日付を日付型(Date型)へ変換一度変換することです

どれをどうしたらいいのでしょうか? (;^_^A アセアセ・・・

プログラムを見る限りでは、1日から+1ずつしていくみたいな感じなんですが

理解に悩んでおりますww (;^_^A アセアセ・・・

【14299】Re:CSVファイルを読み込む
回答  ちゃっぴ  - 04/5/25(火) 16:26 -

引用なし
パスワード
   エクセルでは日付を小数点つきの数(シリアル値=Date型)で表します。
つまりDate型に変換してやると、整数部分が日をあらわし、小数部分が時間を表します。

> datDataDate = datDataDate + 1

これはDate型変数に1を加算してますので、つまり、日が1日値進むというわけです。

お分かりになりましたか?

【14306】Re:CSVファイルを読み込む
回答  アスキー  - 04/5/25(火) 17:01 -

引用なし
パスワード
   ありがとうございます

CDateの動きはわかりました。
38108を入力すると、2004/05/01を表示しました^^

それでですが、
datDataDate = CDate(YEAR1 & "/" & MONTH1 & "/" & DAY1)
これの意味がよくわかりません

Forでループさせるのも何とか理解しました
strFileName = PASS1 & Format$(datDataDate, "yyyymmdd") & ".xls
ここがわからないですw (;^_^A アセアセ・・・

何度もすいません、少しずつは理解してるのですが
何分素人なものでw 

【14307】Re:CSVファイルを読み込む
回答  ちゃっぴ  - 04/5/25(火) 17:11 -

引用なし
パスワード
   >datDataDate = CDate(YEAR1 & "/" & MONTH1 & "/" & DAY1)
>これの意味がよくわかりません

YEAR1,MONTH1,DAY1は文字列(String)型変数です。
テキストボックスの値を先に代入しておいてください。

例)YEAR1 = TextBox1.Text

つまり、テキストボックスに入力された値がそれぞれ
「2004」,「5」,「25」であれば
「2004/5/25」としてから日付型に変換し、
日付型の変数に代入します。

>strFileName = PASS1 & Format$(datDataDate, "yyyymmdd") & ".xls
>ここがわからないですw (;^_^A アセアセ・・・

Format$関数を使用し、日付型の変数を"yyyymmdd"形式の文字列型変数に
変換しています。

ちなみにPASS1、.xlsは必要に応じて書き換えてください。

>何度もすいません、少しずつは理解してるのですが
>何分素人なものでw 

がんばってください。その息です。p(・∩・)qガンバレ!

【14310】Re:CSVファイルを読み込む
発言  アスキー  - 04/5/25(火) 18:16 -

引用なし
パスワード
   応援ありがとうございます
わずかながらずつ理解してきました

ここまで作ってみました

Option Explicit
Sub CommandButton1_Click()
月報読み込み.Hide
End Sub
Sub CommandButton2_Click()
Dim PASS1    As String
Dim YEAR1    As String
Dim MONTH1   As String
Dim DAY1    As String
Dim FILEPASS6  As String
Dim FILE6    As String
Dim i      As Integer
Dim DayCount  As String
Dim datDataDate As Date
Dim strFileName As String
PASS1 = TextBox5.Text
YEAR1 = TextBox1.Text
MONTH1 = TextBox2.Text
DAY1 = TextBox3.Text
DayCount = TextBox4.Text
On Error GoTo ERR:

datDataDate = CDate(YEAR1 & "/" & MONTH1 & "/" & DAY1)
  For i = 1 To DayCount 'DayCountまでループ(日指定)
    'ファイル名生成
    strFileName = PASS1 & Format$(datDataDate, "yyyymmdd") & ".xls"
  
    'CSV読込処理を記述
  
    datDataDate = datDataDate + 1 '1日進む
  Next i
ERR:
Const TITLE = "MsgBox"
MsgBox "エラ−が発生しました。" & Chr(13) & Chr(13) & "Error Number =" & ERR.Number & Chr(13) & "Error Message=" & ERR.Description, , TITLE
ActiveWindow.Close

月報読み込み.Hide
Exit_CommandButton2_Click:
End Sub
Sub UserForm_Activate()
TextBox5.Value = "D:\Data Folder\"
TextBox1.Value = "2004"
TextBox2.Value = "05"
TextBox3.Value = "01"
TextBox4.Value = "31"
End Sub

これで実行するとエラーで、終了します

'ファイル名生成
strFileName = PASS1 & Format$(datDataDate, "yyyymmdd") & ".xls"

やっぱり、ここの部分がわかりません (´;ェ;`)ウゥ・・・

【14312】Re:CSVファイルを読み込む
回答  [名前なし]  - 04/5/25(火) 18:59 -

引用なし
パスワード
   >これで実行するとエラーで、終了します

どこでどういったエラーが発生しますか?

普通に流れると自然にErrorラベルの箇所に行くと思いますが・・・
Errorラベルの前にExit Subがないので・・・

>strFileName = PASS1 & Format$(datDataDate, "yyyymmdd") & ".xls"

この箇所がエラーになるとは思えませんが・・・

【14315】Re:CSVファイルを読み込む
回答  Hirofumi E-MAIL  - 04/5/25(火) 21:05 -

引用なし
パスワード
   チョット違うけど、こんなのも有るよ
CsvDataReadと言うマクロを実行すると「フォーマット.xls」がOpenされ
「ファイルを開く」ダイアログが表示されます
ここで、Csvファイルをを複数選択すると、選択されたファイルが
「フォーマット.xls」にシートが追加され、1シート1ファイルとして、
其処へ読み込まれます
「実行ファイルという名のExcelのブック」のコマンドボタンで「Sub CsvDataRead」を
実行する様にして下さい
また、「フォーマット.xls」の有る場所は、現状のコードでは、
「実行ファイルという名のExcelのブック」と同じフォルダとしていますので
これは実状に合わせて下さい

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
  
  'Csvファイルを読み込むBookをOpen
  Workbooks.Open ThisWorkbook.Path _
          & "\" & "フォーマット.xls"
  
  'Csvファイルの有るフォルダを指定
  strPath = ActiveWorkbook.Path
'  strPath = "D:\Data Folder"
  '「ファイルを開く」ダイアログを複数選択で表示
  If Not GetReadFile(vntFileNames, strPath, True) 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
    'シート名を変更
    wksWrite.Name = strSheetName
    '出力する先頭行を設定
    lngWriteRow = 1
    'CSVを書き込み
    CSVRead vntFileNames(i), _
          wksWrite, lngWriteRow, 1
'    wksWrite.Columns.AutoFit
  Next i
  
  Set wksWrite = Nothing
  
'  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
  Dim blnMulti As Boolean
  Dim strRec As String
  
  '空きファイルバファ番号を取得
  dfn = FreeFile
  'ファイルをInputモードで開く
  Open strFileName For Input As dfn
  
  'ファイルエンドまで繰り返し
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    'レコードをフィールドに分割
    vntField = SplitCsv(strBuff, ",", , , blnMulti)
    '物理レコードに改行が有った場合
    If blnMulti Then
      strRec = strRec & vbLf
    Else
      '指定シートの指定列、行について
      With wksWrite.Cells(lngRow, lngCol)
        '結果配列を代入
        .Offset.Resize(, UBound(vntField) + 1) = vntField
      End With
      '書き込み行を更新
      lngRow = lngRow + 1
      '論理レコードをクリア
      strRec = ""
    End If
  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," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  
  '読み込むファイルの有るフォルダを指定
  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 GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt"
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  '「ファイルを保存」ダイアログを表示
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 1)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function

Private Function GetSheetName(ByVal strName As String, _
        Optional ByVal wkbBook As Workbook) As String

'  同一シート名の存在確認と枝番付加

  Dim i As Long
  Dim lngPos As Long
  Dim lngNumb As Long
  Dim lngTmpNumb As Long
  Dim strSName As String
  
  If wkbBook Is Nothing Then
    Set wkbBook = ThisWorkbook
  End If
  
  lngPos = Len(strName) + 1
  lngNumb = -1
  With wkbBook
    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
  
  Set wkbBook = Nothing
  
  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

【14317】Re:CSVファイルを読み込む
回答  Hirofumi E-MAIL  - 04/5/25(火) 21:44 -

引用なし
パスワード
   間違えた!
以下の部分を修正して下さい

「Sub CSVRead」の中の

    'レコードをフィールドに分割
    vntField = SplitCsv(strBuff, ",", , , blnMulti)



    'レコードをフィールドに分割
    vntField = SplitCsv(strRec, ",", , , blnMulti)

に修正して下さい

【14399】Re:CSVファイルを読み込む
発言  アスキー  - 04/5/28(金) 9:11 -

引用なし
パスワード
   ありがとうございます

昨日まで色々と試行錯誤してましたが

このプログラムだと簡単にいけそうな感じがします

このプログラム、ありがたく使わせて頂きます

後日、進展ご報告いたします

ここにレスしていただいた方に、深く感謝したいと思います

ありがとうございます

【14517】Re:CSVファイルを読み込む
質問  アスキー  - 04/5/31(月) 17:50 -

引用なし
パスワード
   色々と手を加えていい感じのものができました

そこでまた壁にぶつかってしまったので質問させて頂きます
前レスの、Hirofumi様のマクロを利用しましてプログラムを作成しました

フォーマットファイルとして、月報フォーマット.xlsというファイルを作り
その中に、月報というSheetが1つだけあります

マクロを実行すると、その月報フォーマット.xlsに選択したcsvファイルが

シートごとに移動するものになっております

マクロ実行後に、月報のSheetに戻すようにしたんですが

そこでもう一処理させようと考えました

月報Sheet上に、フォームでコンボボックスを作成し

コンボボックスでは、0時〜23時という内容を選択できるようにし

0時を選択すると、移動させた複数のSheetの内容の0時の行の内容を

月報Sheetにコピーさせたいのです

Sheet間のコピーは本を読みながらできたんですが

Sheetの名前が不規則な場合だと、処理がどうもできません

お知恵をお貸しください お願いします

【14527】Re:CSVファイルを読み込む
発言  Hirofumi  - 04/5/31(月) 20:33 -

引用なし
パスワード
   まず、何を何処から、何処え、同言う手段で此れがキチント説明されなければ答え様が無いのですが?
私には、アスキーさんのBook、データは見えませんので

詰まり、月報フォーマット.xlsに元から有るSheetが「月報Sheet」なのですね?
では、「月報Sheet」のレイアウトはどうなっているのですか?
次に、月報フォーマット.xlsに追加される、Csvのデータ(日報データ?)は、同言うレイアウトなのですか?
次に、「月報Sheet上に、フォームでコンボボックスを作成し」フォームとは何、UserFormですか?
次に、このコンボボックスで選択された、時間を各日報シートの何処から探すのですか?
また、この時間とは、時間のシリアル値なのですか?、文字列なのですか?
こらは、Sheetの何列何行から書いて有るのですか?
次に、コピー先の「月報Sheet」の何処に、日報シートの何を張りつけるのですか?

この様な事を詳しく説明して下さい

【14536】Re:CSVファイルを読み込む
質問  アスキー E-MAIL  - 04/6/1(火) 1:33 -

引用なし
パスワード
   Hirofumi様、お返事ありがとうございます
おっしゃる通りで、掲示板を見ただけではわからないですね (^^;
もう一度、詳しく説明いたします 申し訳ございません

まず、DataFolderフォルダに
   ・月報フォーマット.xls
   ・実行ファイル.xls   の二つがあります

このフォルダに、csvファイルがどんどん溜まっていきます
(例:20040501や、20040531や、20040615などとファイル名はその日の日付です)


月報フォーマット.xlsには、"月報"というシートがあります
月報のフォーマットは下記のようになっています
(1〜6はタイトルなどがありあまして)
  A  B   C   D   E   F   ・・ R
1
2
3             ○○○○年○○月
4             ↑このように表示されるセルの書式にしています
5
6
7    温度1 温度2 温度3 温度4 温度5    ・・温度17
8     ℃   ℃   ℃   ℃   ℃      ℃
9  1日
10 2日
11 3日
12 4日
13 5日
14 6日
15 7日


38 30日
39 31日
40平均値
41最大値
42最小値

-----------------------------------------------------------------------

次に、csvデータ(日報のデータです)のレイアウトは下記のようになっています
例:20040501.csv のファイルです

  A  B   C   D   E   F   ・・ R
1       2004/5/1
2    温度1 温度2 温度3 温度4 温度5    ・・温度17
3     ℃   ℃   ℃   ℃   ℃      ℃
4 0:00  15.0  17.0  ←こんな感じでデータが入力されています
5 1:00
6 2:00


25 21:00
26 22:00
27 23:00
28
29平均値
30最大値
31最小値

-------------------------------------------------------------------------

1..実行ファイルにあるマクロを実行すると、ダイアログボックが表示されます
2..ここで、月報へ反映させたいcsvファイルを選びます
 (5月であれば、20040501.csv〜20040531.csvを選択です)
3..すると、月報フォーマットの新しいシートへ次々とファイルが反映されていきます
  その時のシートの名前は、csvファイルと同じ名前です
 (多い月だと31枚のシートが作成されます)
4..ここからが、お聞きしたい部分になります
  この月報フォーマットに1ヶ月分のシートから、○○時のデータだけを取り出す
  といった処理をしたいのです
  例えばですが、月報フォーマット.xls上にマクロを作成し
  ダイアログボックスを表示させ、手動で数値を入力するようなものを作ります
  5月の月報を作成したい場合なら、まず、3.までの処理を行います
  そして、数値を入力するマクロを実行(例:13時)
  実行すると、シートから(31枚より)13時のデータが次々と
  月報フォーマットへコピーされるような処理です

5..前のレスでは、コンボボックスからなどと書きましたが
  ○○時と選べれば何でも結構です

以上が私ながら一生懸命考えた説明でしたが
これでも不明な点がございましたら
再度説明したいと思いますので、お手数ですが
何卒お力をお貸しください! 宜しくお願いいたします

【14562】Re:CSVファイルを読み込む
回答  Hirofumi  - 04/6/1(火) 22:43 -

引用なし
パスワード
   チョット時間が無いので
取り合えずこんな物でお茶を濁します

月報の日にち、日報の時間の行が固定されているので
日にち、時間はMatchiやFinedで探さず、行位置を計算させています

月報フォーマット、実行ファイルどちらでやっても出来ると思いますが
一応、実行ファイルの方でやって見ました

実行ファイルのSheet1に、
コントロールツールボックスのComboBox1とCommandButton1を張りつけます

ThisWorkbookのコードモジュールに以下を記述して下さい

Private Sub Workbook_Open()

  Dim i As Long
  
  With Worksheets("Sheet1").ComboBox1
    For i = 0 To 23
      .AddItem i
    Next i
  End With
    
End Sub

Sheet1のコードモジュールに以下を記述して下さい

Private Sub CommandButton1_Click()
  
  With Me.ComboBox1
    If .ListIndex <> -1 Then
      DataCopy .Value
    End If
  End With
  
End Sub

標準モジュールに以下を記述して下さい

Option Explicit

Public Sub DataCopy(ByVal lngTime As Long)

  Const strBookName As String = "月報フォーマット.xls"
  Const strResult As String = "月報"
  
  Dim i As Long
  Dim blnExists As Boolean
  Dim wkbData As Workbook
  Dim wksResult As Worksheet
  Dim lngRow As Long
  
  With Workbooks
    For i = 1 To .Count
      If .Item(i).Name = strBookName Then
        blnExists = True
        Exit For
      End If
    Next i
  End With
  If Not blnExists Then
    Beep
    MsgBox "月報フォーマット.xlsがOpenされていません"
    Exit Sub
  End If
  
  Set wkbData = Workbooks(strBookName)
  Set wksResult = wkbData.Worksheets(strResult)
  
  lngTime = lngTime + 4
  With wkbData.Worksheets
    .Item(strResult).Cells(lngRow, "B").Resize(31, 17).ClearContents
    For i = 1 To .Count
      If .Item(i).Name <> strResult Then
        lngRow = Val(Right(.Item(i).Name, 2)) + 9 - 1
        .Item(i).Cells(lngTime, "B").Resize(, 17).Copy _
          Destination:=.Item(strResult).Cells(lngRow, "B")
      End If
    Next i
  End With
  
  Set wksResult = Nothing
  Set wkbData = Nothing
  
  Beep
  MsgBox "処理が完了しました"

End Sub

実行ファイルSheet1のComboBoxで0〜23の数字を選び
CommandButtonを押すと、月報フォーマットの月報に各日付に選択時間の行が
Copyされるはずです
ヤッツケで作っているので、間違っていたらゴメン
其の時は、レスして下さい

【14573】Re:CSVファイルを読み込む
質問  アスキー  - 04/6/2(水) 10:11 -

引用なし
パスワード
   Hirofumi様、お忙しい中、大変感謝いたします
ありがとうございます

当方、月報フォーマット.xlsにお作り頂いたものを
貼り付けて試してみました

月報フォーマット.xlsにComboBox1とCommandButton1を張りつけました
あと、下記を変更してみました

>  With Worksheets("月報").ComboBox1
>    For i = 0 To 23
>      .AddItem i
>    Next i
>  End With

-------------------------------------------------------------

実行ファイルで、「作成」をクリック
 ↓
ダイアログが表示され、csvファイルを指定して「開く」をクリック
 ↓
月報フォーマットが開かれ、csvファイルが次々とシートへ転記されていきます
 ↓
ここで、月報フォーマット上の、先ほど作ったComboBox1より時間を指定して
CommandButton1をクリックしたところエラーがでました
デバックしたところ下記の部分に黄色の表示がでました

実行時エラー'1004'
アプリケーション定義またはオブジェクト定義のエラーです。

>    .Item(strResult).Cells(lngRow, "B").Resize(31, 17).ClearContents

どこを直していいのか、当方の無知差に飽きれてしまいますが
どうかよろしくお願い申し上げます

【14598】Re:CSVファイルを読み込む
発言  アスキー  - 04/6/2(水) 17:38 -

引用なし
パスワード
   追伸
Hirofumi様

当方で色々と思考錯誤していたところ
前レスでエラーが出た箇所を削除して、実行したところ動きました。
下記の部分です

>  .Item(strResult).Cells(lngRow, "B").Resize(31, 17).ClearContents


ここの部分は削除しても問題はないでしょうか?
どのような動きをする部分なのかがわからず
参考書等を読んでは調べてはみたのですが理解に悩んでおります


それと、削除後の動きは問題なく素晴らしいものなのですが
月報のフォーマット上は、罫線で見やすくしておりまして
実行すると、罫線が消えてしまいます
csvファイルに罫線がないというのが問題なのでしょうか?
それとも月報フォーマットの罫線を消さず値だけコピーさせることは可能でしょうか?

ご多忙の中、誠に申し訳ございません

【14603】Re:CSVファイルを読み込む
回答  Hirofumi  - 04/6/2(水) 21:11 -

引用なし
パスワード
   少し書きなおしてコメントを入れて置きました
なお、前は範囲をCopyして張りつけていたのですが
今回、範囲の値を代入しています

また、前回のエラーは私のボケで、lngRowの値が決まる前に使用していました
目的は、範囲をクリアする事です

それと、前回、実行ファイルのBookに記述しなさいと書きましたが
月報フォーマットのBookに同様に書いても動くと思います

書き直したコードを記述します

ThisWorkbookのコードモジュールに以下を記述して下さい

Private Sub Workbook_Open()

  Dim i As Long
  
  With Worksheets("Sheet1").ComboBox1
    For i = 0 To 23
      .AddItem i & "時"
    Next i
  End With
    
End Sub

Sheet1のコードモジュールに以下を記述して下さい

Private Sub CommandButton1_Click()
  
  With Me.ComboBox1
    If .ListIndex <> -1 Then
      DataCopy Val(.Value)
    End If
  End With
  
End Sub

標準モジュールに以下を記述して下さい

Option Explicit

Public Sub DataCopy(ByVal lngTime As Long)

  Const strBookName As String = "月報フォーマット.xls"
  Const strResult As String = "月報"
  
  Dim blnExists As Boolean
  Dim wkbData As Workbook
  Dim wksDaTa As Worksheet
  Dim wksResult As Worksheet
  Dim lngRow As Long
  
  '"月報フォーマット.xls"がOpenされているか確認
  'Workbooksコレクションの全てを繰り返す
  For Each wkbData In Workbooks
    'コレクションの要素の名前が、"月報フォーマット.xls"なら
    If wkbData.Name = strBookName Then
      '存在フラグをTrueに
      blnExists = True
      Exit For
    End If
  Next wkbData
  'Openされていない場合
  If Not blnExists Then
    Beep
    MsgBox "月報フォーマット.xlsがOpenされていません"
    Exit Sub
  End If
  
  '指定された時間の行位置を取得
  lngTime = lngTime + 4
  
  '"月報フォーマット.xls"に就いて
  With Workbooks(strBookName)
    'アクティブに
    .Activate
    '"月報"シートの参照を設定
    Set wksResult = .Worksheets(strResult)
    '"月報"シートのB9:R39をクリア
    wksResult.Cells(9, _
          "B").Resize(31, 17).ClearContents
    'WorkSheetsコレクションの全てを繰り返す
    For Each wksDaTa In .Worksheets
      'コレクションの要素の就いて
      With wksDaTa
        'シート名が"月報"で無いなら
        If .Name <> strResult Then
          'シート名の右二文字を取り出して数値に変換
          '日付を取り出す
          lngRow = Val(Right(.Name, 2))
          '取り出した日付が日付で有るなら
          If lngRow > 0 Then
            '日付を行位置に変換
            lngRow = lngRow + 9 - 1
            '時間の有る行位置の範囲の値を
            '日付の有る行位置の範囲に代入
            wksResult.Cells(lngRow, "B").Resize(, 17).Value _
                = .Cells(lngTime, "B").Resize(, 17).Value
          End If
        End If
      End With
    Next wksDaTa
  End With
  
  Set wksResult = Nothing
  Set wksDaTa = Nothing
  Set wkbData = Nothing
  
  Beep
  MsgBox "処理が完了しました"

End Sub

【14632】Re:CSVファイルを読み込む
お礼  アスキー  - 04/6/3(木) 12:42 -

引用なし
パスワード
   Hirofumi様

お忙しい中、ご丁寧に記述して頂き大変感謝いたしております

途中断念しそうになりましたが、最後に満足な結果が出て

大変感激しております

途中、お力をお貸しくれた方々にもこの場をお借りして

お礼をいいたいと思います。ありがとうございました

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