| |
▼K・Y さん：
おはようございます
それでは、対象行のＡ列を選択（複数可）して実行するコードです。
Sample3は、実行前に選択しておきます。
Sample4はマクロの中で最初に選択させます。
Sub Sample3()
Dim shT As Worksheet
Dim shK As Worksheet
Dim v() As String
Dim i As Long
Dim k As Long
Dim s As String
Dim x As Long
Dim c As Range
Dim z As Long
Dim myA As Range
Dim myCell As Range
Application.ScreenUpdating = False
Set shK = Workbooks("課題.xls").Sheets("Sheet1")
Set shT = Workbooks("タスク.xls").Sheets("Sheet1")
x = shT.Range("A" & shT.Rows.Count).End(xlUp).Row
shK.Parent.Activate '課題.xlsを最前面に
shK.Activate '対象シートを最前面に
If TypeName(Selection) <> "Range" Then
MsgBox "対象行のA列のセルを選択をしてください（複数可）"
Else
Set myA = Intersect(Selection, shK.Columns("A"))
For Each myCell In myA
z = myCell.Row
For Each c In shK.Range("A1:A" & z)
ReDim v(1 To 3)
k = 0
For i = 1 To 3 'A列〜C列
s = shK.Cells(z, i).Value
If Len(s) > 0 Then
k = k + 1
v(k) = s
End If
Next
Next
x = x + 1
If k > 0 Then
ReDim Preserve v(1 To k)
shT.Cells(x, "A").Value = "依" & Join(v, "-")
End If
shT.Cells(x, "C").Value = "依頼" & Format(Val(shK.Cells(z, "L")), "00000")
shT.Cells(x, "K").Value = shK.Cells(z, "Y").Value
Next
End If
shT.Parent.Activate
shT.Select
Set myA = Nothing
Set shT = Nothing
Set shK = Nothing
Application.ScreenUpdating = True
MsgBox "転記終了しました"
End Sub
Sub Sample4()
Dim shT As Worksheet
Dim shK As Worksheet
Dim v() As String
Dim i As Long
Dim k As Long
Dim s As String
Dim x As Long
Dim c As Range
Dim z As Long
Dim myA As Range
Dim myCell As Range
Set shK = Workbooks("課題.xls").Sheets("Sheet1")
Set shT = Workbooks("タスク.xls").Sheets("Sheet1")
x = shT.Range("A" & shT.Rows.Count).End(xlUp).Row
shK.Parent.Activate '課題.xlsを最前面に
shK.Activate '対象シートを最前面に
On Error Resume Next
Set myA = Application.InputBox("対象の行のA列を選択してください(複数可)", Type:=8)
On Error GoTo 0
If Not myA Is Nothing Then
Application.ScreenUpdating = False
Set myA = Intersect(myA, shK.Columns("A"))
For Each myCell In myA
z = myCell.Row
For Each c In shK.Range("A1:A" & z)
ReDim v(1 To 3)
k = 0
For i = 1 To 3 'A列〜C列
s = shK.Cells(z, i).Value
If Len(s) > 0 Then
k = k + 1
v(k) = s
End If
Next
Next
x = x + 1
If k > 0 Then
ReDim Preserve v(1 To k)
shT.Cells(x, "A").Value = "依" & Join(v, "-")
End If
shT.Cells(x, "C").Value = "依頼" & Format(Val(shK.Cells(z, "L")), "00000")
shT.Cells(x, "K").Value = shK.Cells(z, "Y").Value
Next
shT.Parent.Activate
shT.Select
Application.ScreenUpdating = True
MsgBox "転記終了しました"
End If
Set myA = Nothing
Set shT = Nothing
Set shK = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
