Excel VBAに詳しい方教えてください

質問

添付の画像のシート1(左側)の情報をシート2(右側)のへ転記したいです。
転記する際の条件は下記です。

•シート1で会社、部、課、係をシート2のBCDE列へ転記　(部は部、課は課の列に転記)
•シート2にはすでに名前が記入されているので、名前に紐付く会社情報を転記

お力添えのほど何卒宜しくお願いします。

回答No.4

kkkkkm · ベストアンサー

> セル内最後の文字が社や部、課、係で終わるもので設定することは可能でしょうか？

以下のような感じでどうですか。

Sub Test()
Dim FRange As Range, c As Range
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim FStr As String
Dim i As Long

Set Sh1 = Workbooks("Book1").Sheets("Sheet1")
Set Sh2 = Workbooks("Book2").Sheets("Sheet1")
With Sh2
For Each c In Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp))
FStr = Sh1.Cells(c.Row, "A").Value
Set FRange = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Find(FStr, LookAt:=xlWhole)
If Not FRange Is Nothing Then
For i = Range("B:B").Column To Range("E:E").Column
Select Case Right(Sh1.Cells(c.Row, i).Value, 1)
Case "社"
.Cells(FRange.Row, "B").Value = Sh1.Cells(c.Row, i).Value
Case "部"
.Cells(FRange.Row, "C").Value = Sh1.Cells(c.Row, i).Value
Case "課"
.Cells(FRange.Row, "D").Value = Sh1.Cells(c.Row, i).Value
Case "係"
.Cells(FRange.Row, "E").Value = Sh1.Cells(c.Row, i).Value
End Select
Next
End If
Next
End With
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.3

masnoske

> ちなみに、例えばシート1の組織のレベルが会社によって違い統一されていない

会社によって統一されていないのは当たり前です。
[室]や[チーム]や[グループ]や[班]のような部署がある会社もあります。
大きな会社なら[部]の上に[事業部]というのもあるので、[部]との区別をつける工夫も必要です。

名刺からデータベースを作ろうとしておられるなら、素直にシート1 に左詰め（空白セルなし）で部署名を入れるのが取り扱いやすいと思います。

回答No.2

kkkkkm

後だしで条件出すのは鬱陶しいなぁ、場合によっては一からやり直し。
そもそも、先のコードで動いたのかどうなのか結果はどうなんですか、動かないのに先に進んでも仕方がない。

> [部]や[課]の文字が含まれている等でシート2に転記させることは可能でしょうか？

部活課や課税係があたったらどうするんでしょうか?

補足

申し訳ありません。。
先のコードではバッチリ動きました。
>部活課や課税係があたったらどうするんでしょうか?
セル内最後の文字が社や部、課、係で終わるもので設定することは可能でしょうか？

回答No.1

kkkkkm

Sub Test()
Dim FRange As Range, c As Range
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim FStr As String

Set Sh1 = Workbooks("Book1").Sheets("Sheet1")
Set Sh2 = Workbooks("Book2").Sheets("Sheet1")
With Sh2
For Each c In Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp))
FStr = Sh1.Cells(c.Row, "A").Value
Set FRange = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Find(FStr, LookAt:=xlWhole)
If Not FRange Is Nothing Then
.Cells(FRange.Row, "B").Resize(1, 4).Value = Sh1.Cells(c.Row, "B").Resize(1, 4).Value
End If
Next
End With
End Sub

補足

ちなみに、例えばシート1の組織のレベルが会社によって違い統一されていない場合、[部]や[課]の文字が含まれている等でシート2に転記させることは可能でしょうか？
例
組織3の内容が
太郎の会社だと課レベルだが、花子の会社だと係レベルだった場合。