EXCEL VBAの記述をお願いします

質問

添付ファイル1.の表は一カ月のシフト表です各記号で役割があります上段(1)（1）が午前、下段が午後(2)（2）です。お願いしたいのはこのシフト表から2.の表に実績として1日の(1)はだれ（1）はだれ、(2)はだれと代入したいのです。

お願いは代入する式をお願いしたい。
1.の表です
1月
　1日　2日　3日　4日
鈴木　(1) 　(1)
　(2)　(2)　　　　これらは縦横の罫線が引いてあります
佐藤　(1) 　(1)
　(2) 　(2)
山田 　(1)　(1)
　(2)　(2)
伊藤 　(1) 　(1)
　(2) 　(2)

2.の表です
1月
1日 　2日 3日 　4日
(1) 鈴木　伊藤 山田 　山田
(1) 佐藤　鈴木 伊藤 　佐藤
(2) 山田 　佐藤 鈴木 　伊藤
(2) 伊藤 　山田 佐藤 　鈴木
このように1.の表から代入するVBAでの式をお願いいたします
画像添付ファイルもあります

回答No.3

Prome_Lin

ある程度、汎用的には組んでありますが、添付した画像を前提にしています。

まず、何よりも、「VBScript」で組みましたので、「Windows限定」です。

プログラムファイルに目的のエクセルファイルをドラッグ＆ドロップすると、結果を上書き保存します。

以下のプログラムを、メモ帳かテキストエディタに貼り付け、「～.vbs」という名前で保存します。

「～」の部分は、何でもかまいませんが、「.vbs」の部分は、必ず半角です。

できた「～.vbs」ファイルに、これから処理したいエクセルファイルを１つだけ、ドラッグ＆ドロップすると、処理して、上書き保存し、最後に「Finished!」と表示しますので、「OK」を押して、終了してください。

最後に、プログラムの簡単な説明をしますので、質問者の環境に合わせてください（環境に合わせられなかった場合は、言ってください、私の方で、プログラムを直します）。

Option Explicit
Dim a, b, i, j, w, x, y, z
Set w = WScript.Arguments
If w.Count <> 1 Then
MsgBox("ファイルは１つだけです")
WScript.Quit 10
End If
If LCase(Right(w(0), 4)) <> "xlsx" Then
MsgBox("「xlsx」ファイルだけです")
WScript.Quit 10
End If
Set x = CreateObject("Excel.Application")
x.Application.DisplayAlerts = False
x.Visible = False
Set y = x.Workbooks.Open(w(0))
Set z = y.Worksheets(1)
For i = 3 to z.Cells(z.Rows.Count, 4).End(-4162).Row + 1
For j = 5 to z.Cells(2, z.Columns.Count).End(-4159).Column
Select Case z.Cells(i, j).Value
Case "(1)"
a = 7
Case "(1)"
a = 8
Case "(2)"
a = 9
Case "(2)"
a = 10
Case Else
a = 0
End Select
If a <> 0 Then
If i mod 2 = 0 Then
b = 1
Else
b = 0
End If
z.Cells(a, j + 6).Value = z.Cells(i - b, 4).Value
End If
Next
Next
y.SaveAs(w(0))
x.Quit
Set z = Nothing
Set y = Nothing
Set x = Nothing
MsgBox("Finished!")

簡単なプログラムの説明です。

Option Explicit

「厳密に」というような意味です（気にしないでください）。

Set w = WScript.Arguments
If w.Count <> 1 Then
MsgBox("ファイルは１つだけです")
WScript.Quit 10
End If
If LCase(Right(w(0), 4)) <> "xlsx" Then
MsgBox("「xlsx」ファイルだけです")
WScript.Quit 10
End If

この部分は、ファイルがドラッグ＆ドロップされるのを待っていて、ドラッグ＆ドロップされたファイルが１つだけか、最後の４文字が「xlsx」か、調べ、異なれば、プログラムそのものを終了してしまいます。

Set x = CreateObject("Excel.Application")

エクセルを扱えるようにしています。

x.Application.DisplayAlerts = False
x.Visible = False

「上書きしますか」などと聞いてこないようにし、エクセルを表示しないようにしています。

Set y = x.Workbooks.Open(w(0))

ドラッグ＆ドロップされたエクセルファイルを開いています。

Set z = y.Worksheets(1)

一番左端のシートを「z」にセットしています。

For i = 3 to z.Cells(z.Rows.Count, 4).End(-4162).Row + 1

行の処理ですが、３行目がスタート位置です。

最終行は、「お名前」の行の最後＋１です（最後は空白セルのため）。

For j = 5 to z.Cells(2, z.Columns.Count).End(-4159).Column

列は、５列目（列「E」）がスタート位置で、最終列まで処理します。

Select Case z.Cells(i, j).Value
Case "(1)"
a = 7
Case "(1)"
a = 8
Case "(2)"
a = 9
Case "(2)"
a = 10
Case Else
a = 0
End Select

「Select Case」というのは、見てお分かり頂けると思いますが、この場合、セル「z.Cells(i, j).Value」の値を使って

Case "(1)"

「(1)」の場合、「～」と処理します。

a = 7

「(1)」の場合は、何行目かを設定しています。

以下、同じです。

最後に、「Case Else」は、結果的に、何も入っていなかった場合で、「a = 0」としています。

If a <> 0 Then

「a = 0」の場合は、何もしないので、「a」が「0」以外の場合、

If i mod 2 = 0 Then

これから処理する行を２で割ったあまりが「0」の場合、

b = 1

Else
b = 0

それ以外の場合は、「b = 1」。

これは何をしているかというと、お名前の入っているセルを求めるのに必要な処理を行っています。

z.Cells(a, j + 6).Value = z.Cells(i - b, 4).Value

「(1)」の場合は、「a = 7」なので、書き込む方は「７行目」の、列「j + 6」に、お名前を書き込んでいます。

行が「3、4」の場合、まず、「3÷2」のあまりは「1」、「4÷2」のあまりは「0」です。

あまりが「1」のときは、「b = 0」、あまりが「0」のときは「b = 1」、したがって、「i - b」で、「3」ときは「3」、「4」のときも「3」という値が得られ、お名前の行になるわけです。

y.SaveAs(w(0))

上書き保存しています。

x.Quit

エクセルそのものを終了しています。

Set z = Nothing
Set y = Nothing
Set x = Nothing
MsgBox("Finished!")

終了処理をし、最後に「Finished!」と表示しています。

回答No.2

tsubu-yuki

なるほど、それを作ってくれ、と。
なるほどなるほど。

http://www.lancers.jp/work/search/system/vba
参考にどうぞ。

回答No.1

imogasi

VBAをすると式ではなくコードというべきと思う。
ー
「代入する」というより、表を構成しなおすことだろう。
ーー
同じ日の、午前午後それぞれについて、２人いる場合どちらを上の行に持ってくるのか、問題にしないのか。
ーー
堂々とＶＢＡのコード作成してくれという、丸投げ型要求だが、このコーナーは、コード作成代行コーナーでは無かろう。