| |
▼nonoka さん：
では、二つ目の改訂版を。
Sub ふたつ目()
Const fLine As Long = 10 ' データ開始行
Const tLine As Long = 10 ' データ開始行
Dim shTo As Worksheet
Dim Wb As Workbook
Dim c As Range
Dim z As Long
Dim r As Range
Application.ScreenUpdating = False
Set Wb = Workbooks.Open(ThisWorkbook.Path & "\Shipped.xls")
Set shTo = Wb.Worksheets("Shipped")
With ThisWorkbook.Sheets("Schedule")
For Each c In .Range("A" & fLine, .Range("A" & .Rows.Count).End(xlUp))
If c.Value = 1 Then
z = shTo.Range("A" & shTo.Rows.Count).End(xlUp).Row + 1
shTo.Range("A" & z & ":AU" & z).Value = c.EntireRow.Range("A1:AU1").Value
If r Is Nothing Then
Set r = c
Else
Set r = Union(r, c)
End If
End If
Next
If Not r Is Nothing Then r.EntireRow.Delete
Application.Goto shTo.Range("A1")
End With
Application.ScreenUpdating = True
MsgBox "転記完了"
End Sub
|
|
UO3
- 13/2/7(木) 12:14 -
