VBAでデータを別シートにコピーさせ加工をする

前提・実現したいこと

CSVデータを取り込み、取り込んだデータを定義したシートにコピーするプログラムを考えています。
bookにはそれぞれ、メニュー・エクスポート・設定・実行結果のシートがあります。
メニューシート・・・ボタンを設置
エクスポートシート・・・csvで取り込んだデータをただ貼り付けているシート
設定シート・・・実行結果で１行目に出力される項目
実行結果シート・・・ボタン実行後シートが作成される（１行目に設定シートの1行目が出力されるように）

実現したいこと
・番号の列のデータを別シートのidの列に入れたい
・時間データを[h]mm:ssに変換したい
・時間の合計を算出し次の月のデータを繰り返す

よろしくお願いいたします。

発生している問題

取り込むデータは下記

番号,氏名,勤務月,勤務時間,
56,田中花子,5月,11:22,
56,田中花子,6月,34:22:00,
56,田中花子,7月,22:00,

設定シートの1行目は

だった時、実行結果のシートに以下のような出力結果が出るVBAを考えています。

該当のソースコード

Sub Csv_test()
    
    
    Dim A_Sheet
    Dim Csv_Import_File
    
    A_Sheet = ActiveSheet.Name
    
    Csv_Import_File = Application.GetOpenFilename("CSVファイル,*.csv")
    If Csv_Import_File = "False" Then Exit Sub
    
    ThisWorkbook.Sheets("抽出データ").Range("A1:ZZ100000").ClearContents
    
    With Workbooks.Open(Csv_Import_File)
        .Sheets(1).Cells.Copy ThisWorkbook.Sheets("抽出データ").Range("A1")
        .Close
    End With
    
    Worksheets(A_Sheet).Activate
    
    Worksheets("定義データ").Rows(1).Copy
    Worksheets("実行結果").Rows(1).PasteSpecial (xlPasteAll)
    
    
End Sub

補足情報

Excel2013

meg_

2020/05/18 10:10

・質問文中のシート名とコード中のシート名が異なっていてよく分かりません。・現状はどこまでできているのでしょうか？

padnndada

2020/05/18 10:47

メニューシート・・・ボタンを設置抽出データシート・・・csvで取り込んだデータをただ貼り付けているシート定義データシート・・・実行結果で１行目に出力される項目実行結果シート・・・ボタン実行後シートが作成される（１行目に設定シートの1行目が出力されるように）でした。大変失礼いたしました。現状は、csvのデータを抽出データシートに貼り付け、定義データの1行目を実行結果シートに貼り付けまでできています。

meg_

2020/05/18 13:01

質問のコードについて、CSVファイルを開いていません。開いてそのデータをコピーしましょう。

行動規範の内容に同意します

回答2件

ExcelVBA
1Sub Macro1()
2    Dim vFName As Variant
3    Dim rngTop As Range
4    Dim rngBottom As Range
5
6    vFName = Application.GetOpenFilename("CSVファイル,*.csv")
7    If vFName = False Then Exit Sub
8
9    Set rngTop = ThisWorkbook.Sheets("実行結果").Range("C4")
10    
11    With rngTop
12        With .Worksheet.QueryTables.Add(Connection:="TEXT;" & vFName, Destination:=.Cells)
13            .TextFileStartRow = 2               ' 2 行目から読み込み
14            .TextFilePlatform = 932             ' 文字コードを指定
15            .TextFileParseType = xlDelimited    ' 区切り文字の形式
16            .TextFileCommaDelimiter = True      ' カンマ区切り
17            .RefreshStyle = xlOverwriteCells    ' セルに上書き
18            .Refresh                            ' データを表示
19            .Delete                             ' CSV との接続を解除
20        End With
21        Set rngBottom = .End(xlDown)
22    End With
23    
24    With Application.Range(rngTop, rngBottom)
25        .Columns("D:E").NumberFormatLocal = "[h]:mm:ss"
26        With .Columns("E")
27            .FormulaR1C1 = "=sum(r[0]c[-1],r[-1]c[0])"
28            .Value = .Value
29        End With
30    End With
31End Sub

テキストデータのインポートの機能を使えば、余分なシートを汚さなくてもいいかと思います。
マクロの記録をしてみればコードが得られます。

投稿2020/05/22 02:56

mattuwan

総合スコア2163

サンプル作成して見ました。時間部分は文字列にしています。
日時計算は何時も難しい課題になると思われます

Option Explicit
'--------------------------------------------
’(Test_Sample_Miniature)
'対象データ領域は("A2:A100")部分を変更
'--------------------------------------------
' ■■定義追加部分■■■
'--------------------------------------------
Public glngHH As Long
Public glngMM As Long
Public glngSS As Long
Public glngRowCount As Long
Public grng番号 As Range
Public grng氏名 As Range
Public grng何月 As Range
'--------------------------------------------

Sub Test_Sample_Miniature()

    Dim A_Sheet
    Dim Csv_Import_File

    A_Sheet = ActiveSheet.Name

    Csv_Import_File = Application.GetOpenFilename("CSVファイル,*.csv")
    If Csv_Import_File = "False" Then Exit Sub

    ThisWorkbook.Sheets("抽出データ").Range("A1:ZZ100000").ClearContents

    With Workbooks.Open(Csv_Import_File)
        .Sheets(1).Cells.Copy ThisWorkbook.Sheets("抽出データ").Range("A1")
        .Close
    End With

    Worksheets(A_Sheet).Activate

    Worksheets("定義データ").Rows(1).Copy
    Worksheets("実行結果").Rows(1).PasteSpecial (xlPasteAll)

    '--------------------------------------------
    ' ■■以下追加部分■■■
    '--------------------------------------------
    Dim strTime As String
    Dim lngHH As Long
    Dim lngMM As Long
    Dim lngSS As Long
    Dim MyRange As Range
    Dim lngSta As Long
    Dim lngEnd As Long
    Dim strCheckTime As String
    
    glngHH = 0
    glngMM = 0
    glngSS = 0
    glngRowCount = 1
    
    For Each MyRange In Sheets("抽出データ").Range("A2:A100")
        '
        If Trim(MyRange) = "" Then Exit Sub
        strTime = Cells(MyRange.Row, 4).Text
        lngSta = InStr(strTime, ":")
        lngEnd = InStr(lngSta + 1, strTime, ":")
        '
        If lngSta <> 0 Then
            '時間:
            strCheckTime = Left(strTime, InStr(strTime, ":") - 1)
            If IsNumeric(strCheckTime) = True Then
                lngHH = CLng(strCheckTime)
            Else
                MsgBox "Error:TimeData"
                Exit For
            End If
            '
            If lngEnd <> 0 Then
                '分：秒
                strCheckTime = Mid(strTime, lngSta + 1, (lngEnd - lngSta - 1))
                If IsNumeric(strCheckTime) = True Then
                    lngMM = CLng(strCheckTime)
                Else
                    MsgBox "Error:TimeData"
                    Exit For
                End If
                strCheckTime = Mid(strTime, lngEnd + 1)
                If IsNumeric(strCheckTime) = True Then
                    lngSS = CLng(strCheckTime)
                Else
                    MsgBox "Error:TimeData"
                    Exit For
                End If
            Else
                '分
                strCheckTime = Mid(strTime, lngSta + 1)
                If IsNumeric(strCheckTime) = True Then
                    lngMM = CLng(strCheckTime)
                Else
                    MsgBox "Error:TimeData"
                    Exit For
                End If
            End If
        Else
            '時間
            If IsNumeric(strTime) = True Then
                lngHH = CLng(strTime)
            Else
                MsgBox "Error:TimeData"
                Exit For
            End If
        End If
        '
        '書込み時刻編集
        '(秒)
        Do Until lngSS <= 59
            lngMM = lngMM + 1
            lngSS = lngSS - 60
        Loop
        '(分)
        Do Until lngMM <= 59
            lngHH = lngHH + 1
            lngMM = lngMM - 60
        Loop
        '
        Set grng番号 = Sheets("抽出データ").Cells(MyRange.Row, 1)
        Set grng氏名 = Sheets("抽出データ").Cells(MyRange.Row, 2)
        Set grng何月 = Sheets("抽出データ").Cells(MyRange.Row, 3)
        strTime = "'" & Format(lngHH, "00") & ":" & Format(lngMM, "00") & ":" & Format(lngSS, "00")
        'Debug.Print strTime
        Call Write_Process(grng番号, grng氏名, grng何月, lngHH, lngMM, lngSS, strTime)
        '
    Next

    'オブジェクト解放
    Set grng番号 = Nothing
    Set grng氏名 = Nothing
    Set grng何月 = Nothing

End Sub

Function Write_Process( _
ByRef rng番号 As Range, _
ByRef rng氏名 As Range, _
ByRef rng何月 As Range, _
ByRef lngPraHH As Long, _
ByRef lngPraMM As Long, _
ByRef lngPraSS As Long, _
ByRef strPra時間 As String)
    
    Dim lngHH As Long
    Dim lngMM As Long
    Dim lngSS As Long
    Dim strTime As String
    
    Dim Sh As Worksheet
    Set Sh = Sheets("実行結果")
    '
    '時刻加算
    glngHH = glngHH + lngPraHH
    glngMM = glngMM + lngPraMM
    glngSS = glngSS + lngPraSS
    '
    lngHH = glngHH
    lngMM = glngMM
    lngSS = glngSS
    '
    '書込み時刻編集
    '(秒)
    Do Until lngSS <= 59
        lngMM = lngMM + 1
        lngSS = lngSS - 60
    Loop
    '(分)
    Do Until lngMM <= 59
        lngHH = lngHH + 1
        lngMM = lngMM - 60
    Loop
    strTime = "'" & Format(lngHH, "00") & ":" & Format(lngMM, "00") & ":" & Format(lngSS, "00")
    '
    '最終書込み
    glngRowCount = glngRowCount + 1
    '
    Sh.Cells(rng番号.Row, rng番号.Column) = rng番号
    Sh.Cells(rng氏名.Row, rng氏名.Column) = rng氏名
    Sh.Cells(rng何月.Row, rng何月.Column) = rng何月
    Sh.Cells(rng何月.Row, rng何月.Column + 1) = strPra時間
    Sh.Cells(rng何月.Row, rng何月.Column + 2) = strTime
    '
    '解放
    Set Sh = Nothing

End Function

投稿2020/05/22 01:18

編集2020/05/22 20:10