初めまして。
ExcelのVBAコードの件で質問させて下さい。


このようなCSVがあります。

氏名,勤務日,開始時間,終了時間
山田花子,2017/05/01,8:00,17:00
山田花子,2017/05/02,8:00,18:00
山田花子,2017/05/03,8:00,17:00
山田花子,2017/05/04,8:00,17:00
佐藤隆司,2017/05/01,8:00,17:00
佐藤隆司,2017/05/02,8:00,17:00
佐藤隆司,2017/05/03,8:00,18:00
佐藤隆司,2017/05/04,8:00,17:00
斉藤信夫,2017/05/01,8:00,17:00
斉藤信夫,2017/05/02,8:00,18:00
斉藤信夫,2017/05/03,8:00,17:00
斉藤信夫,2017/05/04,8:00,18:00
(勤務表なので、実際は30行または31行ずつあります

CSVを選択し取り込むと
山田花子さんの行はsheet1、
佐藤隆司さんの行はsheet2、
斉藤信夫さんの行はsheet3の
指定されたセル(仮に、P8セルとします)から貼り付けされるような
コードが知りたいです。

可能でしたら、ボタンをクリックするとCSVを選択できるボックスが出てくるような感じだと有難いです。

説明下手な上に、他力本願でお恥ずかしいのですが
どうぞ宜しくお願い申し上げます。

A 回答 (2件)

他力本願でも、多少とも、コードを読む努力はしてください。


シートに設定されていない人は、シートがひとつ加わります。
しかし、氏名の表記のゆれは、現行では吸収できませんので、ゆれがないようにしてください。

ボタンは、ご自身でつけてください。
実行する前に、実際のタイムカードデータのフォルダー先と、スタートアドレスを「スタート設定」に入れてください。

'//
Sub SortinOutMenbers()
Dim FileName As Variant
Dim FNo As Integer
Dim TextLine As String
Dim i As Long, j As Long, m As Long
Dim arbuf()
Dim Title As Variant
Dim myDir As String
Dim SCL As Long
' ********スタート設定*******
Const CL = "P" 'P8の場合
Const SRW = 8  '1を入れるとエラーが出ます。項目行が1行前に出るからです。
'データのある場所
myDir = "C:\Users\[User]\Documents\Test\"
'**********************

SCL = Range(CL & "1").Column '列を数値に変換
ChDir myDir

FileName = Application.GetOpenFilename("csvファイル(*.csv),*.csv", , "ファイル選択")
If VarType(FileName) = vbBoolean Or FileName = "" Then Exit Sub
FNo = FreeFile()
 Open FileName For Input As #FNo
 Do While Not EOF(FNo)
  Line Input #FNo, TextLine
  ReDim Preserve arbuf(j)
  arbuf(j) = Split(TextLine, ",")
  j = j + 1
 Loop
 Close #FNo

Call MakingSheets(arbuf())
Title = Join(arbuf(0), ",")
Title = Split(Replace(Title, "氏名,", ""), ",")
For i = LBound(arbuf) + 1 To UBound(arbuf)
 If UBound(arbuf(i)) > 0 Then
 With Worksheets(arbuf(i)(0))
  j = .Cells(Rows.Count, SCL).End(xlUp).Row '始める位置
  If j < SRW Then
   .Cells(SRW - 1, SCL).Resize(, 3).Value = Title
   j = SRW
  Else
   j = j + 1
  End If
  For m = 1 To UBound(arbuf(i))
   .Cells(j, SCL - 1 + m).Value = arbuf(i)(m)
  Next
 End With
 End If
Next

End Sub
Sub MakingSheets(ar())
'シートがあるか検索、なければシートを作る
Dim objDic As Object
Dim i As Long, j As Long
Dim dumm As Variant 'ダミー
Dim nm As Variant '氏名

Set objDic = CreateObject("Scripting.Dictionary")
  For i = LBound(ar) + 1 To UBound(ar)
   If UBound(ar(i)) > 0 Then
   nm = Trim(ar(i)(0))
   If Not objDic.Exists(nm) Then
    j = j + 1
    objDic.Add nm, j
    On Error Resume Next
    dumm = Worksheets(nm).Range("A1")
    If Err <> 0 Then
     Worksheets.Add After:=Worksheets(Worksheets.Count)
     ActiveSheet.Name = nm
    End If
    dumm = Null
    On Error GoTo 0
   End If
   End If
  Next
End Sub
    • good
    • 0

VBAコードではありませんが、私なら次のようにします。


sheet1はCSVファイルを張り付けるシート、
sheet2、sheet3、…にはsheet1のデータを基にしたテーブルを用意しておく。
sheet2、sheet3、…のテーブルのフィルタでそれぞれ、山田花子、佐藤隆司、斉藤信夫、…のセルがある行を抽出する。
次回からは、CSVの貼り付けと各シートにあるテーブルで人名で抽出する。
CSVの貼り付けと各シートにあるテーブルでの人名による抽出の作業を「マクロの記録」で記録して保存したらVBAコードが作れるかもしれません。
あるいは、
sheet2にsheet1のデータを基にしたテーブルを用意しておく。
sheet2のテーブルのフィルタでそれぞれ、山田花子、佐藤隆司、斉藤信夫、…のセルがある行を抽出したら、
それぞれの結果をコピー(Ctrl+C)してsheet3、sheet4、…のシートに貼り付ける(Ctrl+V)。
CSVの貼り付けと人名での抽出作業と結果のコピー&ペーストの一連の作業を「マクロの記録」で記録して保存したらVBAコードが作れるかもしれません。
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング