プロが教える店舗＆オフィスのセキュリティ対策術

VBAで複雑な構成の転記

解決済

  • 質問者：marony1115
  • 質問日時：
  • 回答数：6件

はじめまして。

VBAで複雑な表の転記をする必要があり大変困っています(>_<)
内容は、社員別で8行1セットのデータを、1人当たり3行毎に転記し、評価一覧を作成したいです。

データイメージは画像のとおりです。
※結果は、1人当たり1-3段(行)に分けてそれぞれ転記したいです。

VBAに詳しい方がいらっしゃいましたら是非アドバイス頂けませんでしょうか。

【元データ】
・A列ーQ列のデータ
・1人8行セット
・3行目からデータ
列 項目
A 社員番号
B 氏名
C 会社
D 職位
E レベル
F レビュータイプ
G 総合評価
H 監督者評価(平均)
I 本人評価(平均)
J 目標
K 監督者評価1
L 本人評価1
M 監督者評価2
N 本人評価2
O 定義
P 監督者評価3
Q 本人評価3

【先データ】
・A-BO列のデータ
・1人３行セット
・5行目からデータ
列 行(1人目) セット項目
A 5-6 　　　社員番号
B 5-6 　　　氏名
C
D
E
F
G 5-6 　　　レベル
H
I 5-6 　　　会社
J
K
L
M
N
O 7 　　　監督者評価(平均)
P 5 　　　目標1
Q 5 　　　目標2
R 5 　　　目標3
S 5 　　　目標4
T 5 　　　目標5
P 6
Q 6
R 6
S 6
T 6
P 7 　　　監督評価1
Q 7 　　　監督評価1
R 7 　　　監督評価1
S 7 　　　監督評価1
T 7 　　　監督評価1
U 7 　　　監督評価2
V 7 　　　監督評価3
W 7 　　　監督評価3
X 7 　　　監督評価3
Y 7 　　　監督評価3
Z 7 　　　監督評価3
AA 7 　　　監督評価3
AB 7 　　　監督評価3
AC 7 　　　監督評価3
AD
AE
AF
AG
AH
AI
AJ
AK
AL
AM
AN
AO
AP
AQ
AR
AS
AT
AU
AV
AW
AX
AY
AZ
BA 5
BB 5 　　　本人評価1
BC 5 　　　本人評価1
BD 5 　　　本人評価1
BE 5 　　　本人評価1
BF 5 　　　本人評価1
BB 7
BC 7
BD 7
BE 7
BF 7
BG 7 　　　本人評価2
BH 7 　　　本人評価3
BI 7 　　　本人評価3
BJ 7 　　　本人評価3
BK 7 　　　本人評価3
BL 7 　　　本人評価3
BM 7 　　　本人評価3
BN 7 　　　本人評価3
BO 7 　　　本人評価3

「VBAで複雑な構成の転記」の質問画像

質問者からの補足コメント

  • 補足１：元データ

    「VBAで複雑な構成の転記」の補足画像1
      補足日時：2018/09/03 14:31
    通報する

  • 補足２：転記先データ１

    「VBAで複雑な構成の転記」の補足画像2
      補足日時：2018/09/03 14:33
    通報する

  • 補足３：転記先データ２

    「VBAで複雑な構成の転記」の補足画像3
      補足日時：2018/09/03 14:33
    通報する

  • 【追加要件】
    ①転記元「データ」シートG列の記号(8行毎に入力されている)を記号別でカウントし、それぞれの社員数を算出する。
    →転記先「組織内分布一覧」シートのB3-B7に転記

    ②記号毎のの分布割合を算出する。((100/社員数合計)×記号別人数)
    →転記先「組織内分布一覧」シートのC3-C7に転記

    「VBAで複雑な構成の転記」の補足画像4
      補足日時：2018/09/05 16:28
    通報する
通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (6件)

No.3ベストアンサー

  • 回答者： tatsu99
  • 回答日時：

以下のマクロを標準モジュールに登録してください。


転記先の見出し、罫線については、予め適切に設定されているものとします。
（マクロでは行いません。マクロはデータの転記のみ行います）
---------------------------------------------
Option Explicit
Public Sub 複雑な構成の転記()
Const Non As String = "-" 'データなし
Dim maxrow As Long
Dim row As Long
Dim row2 As Long
Dim ctr As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("データ")
Set sh2 = Worksheets("社員別評価一覧")
maxrow = sh1.Cells(Rows.Count, 1).End(xlUp).row 'sheetデータの最大行取得
If (maxrow - 2) Mod 8 <> 0 Then
MsgBox ("データの行不正")
Exit Sub
End If
sh2.Rows("5:" & Rows.Count).ClearContents 'Sheet社員別評価一覧の5行目以降をクリア
'転記を最後の行まで行う
ctr = 0
row2 = 5
For row = 3 To maxrow Step 8
sh2.Cells(row2, "A").Value = sh1.Cells(row, "A").Value '社員番号
sh2.Cells(row2, "B").Value = sh1.Cells(row, "B").Value '氏名
sh2.Cells(row2, "G").Value = sh1.Cells(row, "E").Value 'レベル
sh2.Cells(row2, "I").Value = sh1.Cells(row, "C").Value '会社
sh2.Cells(row2 + 2, "O").Value = sh1.Cells(row, "H").Value '監督者評価（平均）
sh2.Cells(row2, "P").Value = sh1.Cells(row, "J").Value '目標１
sh2.Cells(row2, "Q").Value = sh1.Cells(row + 1, "J").Value '目標２
sh2.Cells(row2, "R").Value = sh1.Cells(row + 2, "J").Value '目標３
sh2.Cells(row2, "S").Value = sh1.Cells(row + 3, "J").Value '目標４
sh2.Cells(row2, "T").Value = sh1.Cells(row + 4, "J").Value '目標５
sh2.Cells(row2 + 2, "P").Value = sh1.Cells(row, "K").Value '監督者評価１
sh2.Cells(row2 + 2, "Q").Value = sh1.Cells(row + 1, "K").Value '監督者評価１
sh2.Cells(row2 + 2, "R").Value = sh1.Cells(row + 2, "K").Value '監督者評価１
sh2.Cells(row2 + 2, "S").Value = sh1.Cells(row + 3, "K").Value '監督者評価１
sh2.Cells(row2 + 2, "T").Value = sh1.Cells(row + 4, "K").Value '監督者評価１
sh2.Cells(row2 + 2, "U").Value = sh1.Cells(row, "M").Value '監督者評価２
sh2.Cells(row2 + 2, "V").Value = sh1.Cells(row, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "W").Value = sh1.Cells(row + 1, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "X").Value = sh1.Cells(row + 2, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "Y").Value = sh1.Cells(row + 3, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "Z").Value = sh1.Cells(row + 4, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "AA").Value = sh1.Cells(row + 5, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "AB").Value = sh1.Cells(row + 6, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "AC").Value = sh1.Cells(row + 7, "P").Value '監督者評価３
sh2.Cells(row2, "BB").Value = sh1.Cells(row, "L").Value '本人評価１
sh2.Cells(row2, "BC").Value = sh1.Cells(row + 1, "L").Value '本人評価１
sh2.Cells(row2, "BD").Value = sh1.Cells(row + 2, "L").Value '本人評価１
sh2.Cells(row2, "BE").Value = sh1.Cells(row + 3, "L").Value '本人評価１
sh2.Cells(row2, "BF").Value = sh1.Cells(row + 4, "L").Value '本人評価１
sh2.Cells(row2 + 2, "BG").Value = sh1.Cells(row, "M").Value '監督者評価２
sh2.Cells(row2 + 2, "BH").Value = sh1.Cells(row, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BI").Value = sh1.Cells(row + 1, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BJ").Value = sh1.Cells(row + 2, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BK").Value = sh1.Cells(row + 3, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BL").Value = sh1.Cells(row + 4, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BM").Value = sh1.Cells(row + 5, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BN").Value = sh1.Cells(row + 6, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BO").Value = sh1.Cells(row + 7, "P").Value '監督者評価３
row2 = row2 + 3
ctr = ctr + 1
Next
MsgBox (ctr & "人の複雑な転記完了")
End Sub
    • good
    • 1
    • 件
通報する
この回答へのお礼

助かりました

お世話になっております。
お礼が遅くなりまして申し訳ございません(>_<)

見出し、罫線につきましては既にありましたので、頂いたマクロで
希望どおりの処理が実行されました。
ありがとうございます。

重ねての質問で申し訳ないのですが、
目標のセット処理を０～４回（５回）のループ処理で実施し、
セットのコードを1行にしたい場合、

For k = 0 To 4
'目標無し
If sh1.Cells(row + k, "J") = "" Then
Exit For
End If
sh2.Cells(row2, k + "P").Value = sh1.Cells(row + k, "J").Value
Next

のように記述すると、セット先の列計算でエラーとなるのですが、
計算式に数値(上記の場合は"P"：16列)ではなく"P"のように
場所を指定して算出することは出来ますでしょうか。

通報する
お礼日時：2018/09/05 15:55

No.6

  • 回答者： tatsu99
  • 回答日時：

追加要件対応のマクロです。


----------------------------------------------------
Public Sub 組織内分布一覧転記()
Dim maxrow As Long
Dim row1 As Long
Dim row2 As Long
Dim ctr As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("データ")
Set sh2 = Worksheets("組織内分布一覧")
maxrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'sheetデータの最大行取得
If (maxrow - 2) Mod 8 <> 0 Then
MsgBox ("データの行不正")
Exit Sub
End If
sh2.Range("B3:C7").Value = 0
ctr = 0
For row1 = 3 To maxrow Step 8
ctr = ctr + 1
For row2 = 3 To 7
If sh1.Cells(row1, "G").Value = sh2.Cells(row2, "A").Value Then
sh2.Cells(row2, "B").Value = sh2.Cells(row2, "B").Value + 1 '人数に１加算
Exit For
End If
Next
Next
For row2 = 3 To 7
sh2.Cells(row2, "C").Value = 100 * sh2.Cells(row2, "B").Value / ctr '割合設定
Next
MsgBox ("組織内分布一覧転記完了")
End Sub
    • good
    • 1
    • 件
通報する
この回答へのお礼

助かりました

お礼コメントにてこちらの追加要件についてお聞きしようと思っていたのですが、
早速ご対応いただきましてありがとうございます！
希望どおりの結果が作成出来ました。
大変助かりました。

こちらの質問とは異なるのですが、以前ご作成頂いた「異動会社別増減一覧」
にも機能を追加する必要が出てしまいました(>_<)
別途質問させて頂きたいのですが、
もしお時間ございましたらご教授いただけないでしょうか。
お忙しいところ申し訳ございません。
よろしくお願い致します。

通報する
お礼日時：2018/09/10 13:56

No.5

  • 回答者： tatsu99
  • 回答日時：

>For k = 0 To 4


>'目標無し
>If sh1.Cells(row + k, "J") = "" Then
>Exit For
>End If
>sh2.Cells(row2, k + "P").Value = sh1.Cells(row + k, "J").Value
>Next
>のように記述すると、セット先の列計算でエラーとなるのですが、
>計算式に数値(上記の場合は"P"：16列)ではなく"P"のように
>場所を指定して算出することは出来ますでしょうか。

簡単なのは
For k = 0 To 4
If sh1.Cells(Row + k, "J") = "" Then
Exit For
End If
sh2.Cells(row2, 16 + k).Value = sh1.Cells(row + k, "J").Value
Next
のようにする方法です。

もし、16という数字を使わず、"P"をどうしても使いたいなら、
sh2.Cells(row2, "P").Offset(0, k).Value = sh1.Cells(row + k, "J").Value
とすれば、OKです。

For分を使わずに1行で行いたいなら、
sh2.Cells(row2, "P").Resize(1, 5).Value = WorksheetFunction.Transpose(sh1.Range(sh1.Cells(Row, "J"), sh1.Cells(Row + 4, "J")).Value) '目標１～５
としてもOKです。

今回、上記のようなFor文使ったり、Resize文をつかったりしなかったのは、
提示したマクロを質問者の方がメンテナンスする時（例えばA列がC列に変更された場合などのようなケース）に
できるだけメンテナンスしやすいマクロを提供する為です。
（実は、回答したのちに、「列が変わったので、もう一度マクロを作ってほしい」という質問が結構あります）
    • good
    • 1
    • 件
通報する
この回答へのお礼

いくつかのパターンを提示してくださり大変助かりました。

sh2.Cells(row2, "P").Offset(0, k).Value = sh1.Cells(row + k, "J").Value
この形の記述で動きました。ありがとうございます。

私も、 tatsu99様が提示してくださった、ループ処理はあまり使用せず、編集項目毎に処理を記述する方法の方が、内容を理解しやすかったのですが、「社員番号、目標、評価でそれぞれループさせる方法で」と後から指定を受けてしまった為質問させて頂きました。

また、現在セットしていない項目も、今後元データを増やしてセットするようなので、
おっしゃっているように列が変わるのではと思います(>_<)

通報する
お礼日時：2018/09/10 10:23

No.4

  • 回答者： tatsu99
  • 回答日時：

申し訳ありません。

前回の回答に誤りがありました。
本人評価２、３の設定が間違っていました。（コメントも間違っています）
sh2.Cells(row2 + 2, "BG").Value = sh1.Cells(row, "M").Value '監督者評価２
sh2.Cells(row2 + 2, "BH").Value = sh1.Cells(row, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BI").Value = sh1.Cells(row + 1, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BJ").Value = sh1.Cells(row + 2, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BK").Value = sh1.Cells(row + 3, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BL").Value = sh1.Cells(row + 4, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BM").Value = sh1.Cells(row + 5, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BN").Value = sh1.Cells(row + 6, "P").Value '監督者評価３
sh2.Cells(row2 + 2, "BO").Value = sh1.Cells(row + 7, "P").Value '監督者評価３
の箇所を
sh2.Cells(row2 + 2, "BG").Value = sh1.Cells(Row, "N").Value '本人評価２
sh2.Cells(row2 + 2, "BH").Value = sh1.Cells(Row, "Q").Value '本人評価３
sh2.Cells(row2 + 2, "BI").Value = sh1.Cells(Row + 1, "Q").Value '本人評価３
sh2.Cells(row2 + 2, "BJ").Value = sh1.Cells(Row + 2, "Q").Value '本人評価３
sh2.Cells(row2 + 2, "BK").Value = sh1.Cells(Row + 3, "Q").Value '本人評価３
sh2.Cells(row2 + 2, "BL").Value = sh1.Cells(Row + 4, "Q").Value '本人評価３
sh2.Cells(row2 + 2, "BM").Value = sh1.Cells(Row + 5, "Q").Value '本人評価３
sh2.Cells(row2 + 2, "BN").Value = sh1.Cells(Row + 6, "Q").Value '本人評価３
sh2.Cells(row2 + 2, "BO").Value = sh1.Cells(Row + 7, "Q").Value '本人評価３
に変えてください。
    • good
    • 1
    • 件
通報する

No.2

  • 回答者： tatsu99
  • 回答日時：

No1です。


補足ありがとうございました。
先データ：社員別評価一覧
ということですが、先データ１，２は同じシート名ということですか？
先データ１：社員別評価一覧
先データ２：社員別評価一覧

これから外出しますので、続きは夕方以降になります。
    • good
    • 1
    • 件
通報する
この回答へのお礼

おっしゃるとおりです。

あまりにも列数が多くキャプチャで入らなかったので、
2枚に分けさせていただいています。

どちらも「社員別評価一覧」になります。

先データ1：A-AC列
先データ2：AZ－BO列
※AD-AY列はセット項目が無い為非表示にしていますが、列としては存在します。

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

通報する
お礼日時：2018/09/03 15:08

No.1

  • 回答者： tatsu99
  • 回答日時：

補足要求です。


①画像が小さいので、元データ、先データ１，２を別々にして提示していただけませんでしょうか。そうすると大きな画像になるかと。
②元データ、先データ１，２のシート名は何でしょうか。
    • good
    • 1
    • 件
通報する
この回答へのお礼

こんにちは！
いつもありがとうございます(>_<)

①質問の補足に、画像を分けて３枚追記させていただきました。
②シート名ですが、
元データ：データ
先データ：社員別評価一覧
になります。

分かりにくく申し訳ありませんがよろしくお願いいたします。

通報する
お礼日時：2018/09/03 14:37

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

Q質問する（無料）

関連するカテゴリからQ&Aを探す

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報