@hayatedondaposted at 2022-03-08

VBAでCSVのファイル名から日付とファイルのサイズを抽出をしたいです。

Q&A

Excel VBA VBAマクロ

実際にしたい出力後のシート

このように、ファイル名は下に出力していき日付は日付ごとに横に伸び、ファイルサイズはファイルと、日付に当てはまるところに出力される。

現在の進捗
(模範データ)

模範データ←シート名

date    |file  |size
20220101|a_file|250
20220101|b_file|300
20220101|c_file|350
20220101|d_file|400
20220101|e_file|450
20220101|f_file|500
20220101|g_file|550
20220101|h_file|600
20220101|i_file|650
20220101|j_file|700
20220102|a_file|250
20220102|b_file|300
.
.
20220103|j_file|700

(模範処理)

模擬処理←シート名

Sub 開始()
j = 2
f = 6
k = 4

c = 8
d = 3

h = 4
a = 8

For i = 1 To 3
'date
Sheets("模擬データ").Cells(j, 1).Copy
Sheets("模擬処理").Cells(f, k).PasteSpecial xlPasteValues

Cells(f, k).Offset(0, 3).Select

k = k + 3

'file
Sheets("模擬データ").Cells(j, 2).Copy
Sheets("模擬処理").Cells(c, d).PasteSpecial xlPasteValues

Cells(c, d).Offset(0, 1).Select

c = c + 1


'size
Sheets("模擬データ").Cells(j, 3).Copy
Sheets("模擬処理").Cells(a, h).PasteSpecial xlPasteValues

Cells(a, h).Offset(0, 0).Select

a = a + 1
j = j + 1
Next i

自分で試したこと
上記のコードで実行した結果、同じファイル名や同じ日付が立て続けに出力され、ファイルサイズは("D8")から始まり、'実際にしたい出力後のシート'のように次の行に行かず、下に全部出力されてしまう…

どのようにすれば、'実際にしたい出力後のシート'のように出力できますでしょうか？
よろしくお願いいたします。

6Answer

@superrino130 posted at 2022-03-09

山勘で答えますが、ここが役に立っていないと思います。

Cells(f, k).Offset(0, 3).Select

シート間のデータのやり取りは、セルを座標で直接指定しており、
Selectによるセルの移動は意味不明です。

また、クリップボードを利用せず、
次のように直接データを代入したほうが安全と思われます。

'改善前
Sheets("模擬データ").Cells(j, 1).Copy
Sheets("模擬処理").Cells(f, k).PasteSpecial xlPasteValues

'改善後
Sheets("模擬処理").Cells(f, k).value = Sheets("模擬データ").Cells(j, 1).value

1Like

Comments

@hayatedonda
Questioner
ご回答ありがとうございます🙇‍♂️
ご指摘通り直接データを入力して実行出来ました🙇‍♂️
dateのところが同じ日付が立て続けになっているのですが、同じ日付の場合飛ばして次の日付にするにはどうしたら良いのでしょうか？

@superrino130 posted at 2022-03-10

山勘といいますか、実際に動作を確認していませんが、下記の感じになると思います。

Option Explicit

Public Sub moveData()
    Dim data_row As Long, addr_row As Long, addr_col As Long
    
    data_row = 2
    While Worksheets("模擬データ").Cells(data_row, 1) <> ""
        If Worksheets("模擬データ").Cells(data_row, 2).Value = "a_file" Then
            addr_row = 8
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "b_file" Then
            addr_row = 9
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "c_file" Then
            addr_row = 10
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "d_file" Then
            addr_row = 11
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "e_file" Then
            addr_row = 12
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "f_file" Then
            addr_row = 13
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "g_file" Then
            addr_row = 14
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "h_file" Then
            addr_row = 15
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "i_file" Then
            addr_row = 16
        ElseIf Worksheets("模擬データ").Cells(data_row, 2).Value = "j_file" Then
            addr_row = 17
        End If
        addr_col = (Worksheets("模擬データ").Cells(data_row, 1).Value Mod 100) * 3 + 1
        
        Worksheets("模擬処理").Cells(addr_row, addr_col).Value = Worksheets("模擬データ").Cells(data_row, 3).Value
        data_row = data_row + 1
    Loop
End Sub

X_fileの部分は、模擬処理シートから抽出した方がいいのですが。

確実に動作されたい場合は、クラウドワークスなどを利用されてはいかがでしょうか。

1Like

Comments

@hayatedonda
Questioner
例ではa~jまでしかないんですけど、
いっぱいファイルがある場合はどのようにすればいいんですかね？ファイル名を変数にすれば良いのですか？

@superrino130 posted at 2022-03-10

動作確認はしていませんが、ファイル名を検索して行番号を返す形です。

Option Explicit

Public Sub moveData()
    Dim data_row As Long, addr_row As Long, addr_col As Long
    
    data_row = 2
    While Worksheets("模擬データ").Cells(data_row, 1) <> ""
        For addr_row = 8 To 100
            If Worksheets("模擬処理").Cells(addr_row, 3).Value = Worksheets("模擬データ").Cells(data_row, 2) Then
                Exit For
            End If
        Next
        
        addr_col = (Worksheets("模擬データ").Cells(data_row, 1).Value Mod 100) * 3 + 1
        
        Worksheets("模擬処理").Cells(addr_row, addr_col).Value = Worksheets("模擬データ").Cells(data_row, 3).Value
        data_row = data_row + 1
    Loop
End Sub

1Like

Comments

@hayatedonda
Questioner
ありがとうございます🙇‍♂️🙇‍♂️
dateの部分が同じ日付が立て続けに来てるのですが、
本来出力するところでは、1月1日の次は1月2日にしたいのですが、重複した場合次の日付に行くループはどのようにすれば良いのでしょうか？
@superrino130
その部分は、

addr_col = (Worksheets("模擬データ").Cells(data_row, 1).Value Mod 100) * 3 + 1

で対応しているはずです。
@hayatedonda
Questioner
上記のコードをコピーして実行したら何も表示されなかったので、何か残すものはありますでしょうか？
@hayatedonda
Questioner
上記のコード2つを組み合わせる感じですかね？
@superrino130
> 上記のコードをコピーして実行したら何も表示されなかった

山勘で答えますが、模擬処理シートのファイル名列が初期状態で空ですと正しく動作しないです。
@superrino130
While Worksheets("模擬データ").Cells(data_row, 1) <> ""

これを

Do While Worksheets("模擬データ").Cells(data_row, 1) <> ""

にする必要があるようです。
@hayatedonda
Questioner
DoWhileにしたら動いたのですが、やはりdateの部分が立て続けに来てしまいます…
書く場所が違うのでしょうか？
@superrino130
> dateの部分が立て続けに来てしまいます

すいません、イメージがわかないので具体的な例を示していただけますでしょうか
@hayatedonda
Questioner
承知しました🙇‍♂️
少々お待ちくださいm(_ _)m
@superrino130
はい、ありがとうございます。

ちなみに、上記コードで実行した場合の、実行後のシートを見せてもらうことは可能でしょうか
@superrino130
はい、ここで問題は、(1) 日付がすべて1/1になっている、(2) ファイル名が重複している、の２つということでよろしいでしょうか
@hayatedonda
Questioner
(1)全てではないですが1/1が立て続けに来てるので、それを次の1/2日までスキップさせたいです。
(2)その通りです。ファイル名は一つだけ表示されれば良いのです。(CSVから読み込まれるため、元の形式は変えられないです。)

@superrino130 posted at 2022-03-14

(1) 日付がすべて1/1になっている、(2) ファイル名が重複している

このような感じではないでしょうか

Option Explicit

Public Sub moveData()
    Dim data_row As Long, addr_row As Long, addr_col As Long
    
    data_row = 2
    Do While Worksheets("模擬データ").Cells(data_row, 1) <> ""
        addr_row = setFilename(Worksheets("模擬データ").Cells(data_row, 2).Value)
        
        addr_col = (Worksheets("模擬データ").Cells(data_row, 1).Value Mod 100) * 3 + 1
        
        Worksheets("模擬処理").Cells(6, addr_col).Value = Format(Worksheets("模擬データ").Cells(data_row, 1).Value, "@@@@/@@/@@")
        Worksheets("模擬処理").Cells(addr_row, addr_col).Value = Worksheets("模擬データ").Cells(data_row, 3).Value
        data_row = data_row + 1
    Loop
End Sub

Private Function setFilename(fn As String) As Long
    Dim r As Long
    r = 8
    Do While Worksheets("模擬処理").Cells(r, 3).Value <> ""
        If Worksheets("模擬処理").Cells(r, 3).Value = fn Then
            setFilename = r
            Exit Function
        End If
        r = r + 1
    Loop
    setFilename = r
    Worksheets("模擬処理").Cells(r, 3).Value = fn
End Function