Sub 表作成()
' K, M, O列のセルの値をクリア
Range("K:K,M:M,O:O").ClearContents
Dim ws As Worksheet
Dim ws1 As Worksheet
Set ws = Worksheets("表作成")
Set ws1 = Worksheets("WIKI")
Dim lr As Variant
lr = Array(ws.Cells(Rows.Count, 11).End(xlUp).Row, _
ws.Cells(Rows.Count, 13).End(xlUp).Row, _
ws.Cells(Rows.Count, 15).End(xlUp).Row)
Dim i As Variant
i = Array(2, 2)
'転送1行目を抽出
Do While ws1.Cells(i(0), 20) = 1 Or ws1.Cells(i(0), 20) = ""
If ws1.Cells(i(0), 17) <> "" Then
ws1.Cells(i(0), 17).Copy
ws.Cells(lr(0) + 1, 11).PasteSpecial _
Paste:=xlPasteValues
i(0) = i(0) + 1
lr(0) = lr(0) + 1
Else
i(0) = i(0) + 1
End If
Loop
'転送2行目を抽出
Do While ws1.Cells(i(1), 20) = 1 Or ws1.Cells(i(1), 20) = ""
If ws1.Cells(i(1), 18) <> "" Then
ws1.Cells(i(1), 18).Copy
ws.Cells(lr(0) + 1, 11).PasteSpecial _
Paste:=xlPasteValues
i(1) = i(1) + 1
lr(0) = lr(0) + 1
Else
i(1) = i(1) + 1
End If
Loop
'CB1行目を抽出
Do While ws1.Cells(i(0), 20) = 2 Or ws1.Cells(i(0), 20) = ""
If ws1.Cells(i(0), 17) <> "" Then
ws1.Cells(i(0), 17).Copy
ws.Cells(lr(1) + 1, 13).PasteSpecial _
Paste:=xlPasteValues
i(0) = i(0) + 1
lr(1) = lr(1) + 1
Else
i(0) = i(0) + 1
End If
Loop
'CB2行目を抽出
Do While ws1.Cells(i(1), 20) = 2 Or ws1.Cells(i(1), 20) = ""
If ws1.Cells(i(1), 18) <> "" Then
ws1.Cells(i(1), 18).Copy
ws.Cells(lr(1) + 1, 13).PasteSpecial _
Paste:=xlPasteValues
i(1) = i(1) + 1
lr(1) = lr(1) + 1
Else
i(1) = i(1) + 1
End If
Loop
'受電1行目を抽出
Do While ws1.Cells(i(0), 20) = 3 Or ws1.Cells(i(0), 20) = ""
If ws1.Cells(i(0), 17) <> "" Then
ws1.Cells(i(0), 17).Copy
ws.Cells(lr(2) + 1, 15).PasteSpecial _
Paste:=xlPasteValues
i(0) = i(0) + 1
lr(2) = lr(2) + 1
Else
i(0) = i(0) + 1
End If
Loop
'受電2行目を抽出
Do While ws1.Cells(i(1), 20) = 3 Or ws1.Cells(i(1), 20) = ""
If ws1.Cells(i(1), 18) <> "" Then
ws1.Cells(i(1), 18).Copy
ws.Cells(lr(2) + 1, 15).PasteSpecial _
Paste:=xlPasteValues
i(1) = i(1) + 1
lr(2) = lr(2) + 1
Else
i(1) = i(1) + 1
End If
Loop
' 転送表に式を入力
With ws
.Range("E2").Formula = "=IF(K16<>"""",$K2&CHAR(10)&K3&CHAR(10)&K16,$K2&CHAR(10)&K3)"
.Range("F2").Formula = "=IF(K15<>"""",$K4&CHAR(10)&$K5&CHAR(10)&$K15,$K4&CHAR(10)&$K5)"
.Range("G2").Formula = "=IF(K14<>"""",$K6&CHAR(10)&$K7&CHAR(10)&$K14,$K6&CHAR(10)&$K7)"
.Range("H2").Formula = "=IF(K13<>"""",K8&CHAR(10)&K9&CHAR(10)&$K13,K8&CHAR(10)&K9)"
.Range("I2").Formula = "=IF(K12<>"""",K10&CHAR(10)&K11&CHAR(10)&$K12,K10&CHAR(10)&K11)"
' CB表に式を入力
.Range("E3").Formula = "=IF(M16<>"""",$M2&CHAR(10)&M3&CHAR(10)&M16,$M2&CHAR(10)&M3)"
.Range("F3").Formula = "=IF(M15<>"""",$M4&CHAR(10)&$M5&CHAR(10)&$M15,$M4&CHAR(10)&$M5)"
.Range("G3").Formula = "=IF(M14<>"""",$M6&CHAR(10)&$M7&CHAR(10)&$M14,$M6&CHAR(10)&$M7)"
.Range("H3").Formula = "=IF(M13<>"""",M8&CHAR(10)&M9&CHAR(10)&$M13,M8&CHAR(10)&M9)"
.Range("I3").Formula = "=IF(M12<>"""",M10&CHAR(10)&M11&CHAR(10)&$M12,M10&CHAR(10)&M11)"
' 受電表に式を入力
.Range("E4").Formula = "=IF(O16<>"""",$O2&CHAR(10)&O3&CHAR(10)&O16,$O2&CHAR(10)&O3)"
.Range("F4").Formula = "=IF(O15<>"""",$O4&CHAR(10)&$O5&CHAR(10)&$O15,$O4&CHAR(10)&$O5)"
.Range("G4").Formula = "=IF(O14<>"""",$O6&CHAR(10)&$O7&CHAR(10)&$O14,$O6&CHAR(10)&$O7)"
.Range("H4").Formula = "=IF(O13<>"""",O8&CHAR(10)&O9&CHAR(10)&$O13,O8&CHAR(10)&O9)"
.Range("I4").Formula = "=IF(O12<>"""",O10&CHAR(10)&O11&CHAR(10)&$O12,O10&CHAR(10)&O11)"
End With
End Sub