| |
こんにちは
質問と説明通りの条件で動くだけのコードです。
本番データの内容が質問と違っていたので動かないというクレームは無しでお願いします。
質問と違う部分が有ればご自分で修正して下さい。
データが無い場合等のエラー処理はご自分で追加してみて下さい。
Sub test()
Dim nSh As Worksheet
Dim aR As Areas
Dim cR As Range
Dim a As Long
Dim r As String
Dim k As String
Dim h As Long
Set nSh = Worksheets.Add(After:=Worksheets("data"))
Set cR = Worksheets("form").Range("A1:S8")
Application.ScreenUpdating = False
With nSh
.Range("A1:C1").Value = Array("機種名", "品番", "数量")
Worksheets("data").Range("A1").CurrentRegion.Copy .Range("A2")
.Range("A1").Subtotal _
GroupBy:=1, _
Function:=xlCount, _
TotalList:=Array(2), _
Replace:=True, _
PageBreaks:=False, _
SummaryBelowData:=True
With .Range("A1").CurrentRegion
.Value = .Value
End With
.Cells.ClearOutline
.Range("C1").ClearContents
.Columns("C:E").Insert Shift:=xlToRight
Set aR = .Range("A1", .Range("A65536").End(xlUp) _
.Offset(-1)).Offset(, 5) _
.SpecialCells(xlCellTypeBlanks).Areas
With aR
a = .Count
For h = a To 2 Step -1
r = .Item(h - 1).EntireRow.Range("B1").Address
k = .Item(h - 1).EntireRow.Cells(2, 1).Value
If h = a Then
.Item(h).EntireRow.Resize(2).ClearContents
End If
.Item(h).EntireRow.Select
With .Item(h - 1).EntireRow
nSh.Range(r).EntireRow.Delete
cR.Copy
nSh.Range(r).Insert Shift:=xlDown
nSh.Range(r).Range("A6").NumberFormatLocal = "@"
nSh.Range(r).Range("A6").Value = Format(h - 1, "000000")
nSh.Range(r).Range("B6").Value = k
End With
Next
End With
.Range("A:A").Delete
End With
Application.ScreenUpdating = True
Set nSh = Nothing
Set aR = Nothing
Set cR = Nothing
End Sub
|
|
ウッシ
- 07/6/14(木) 12:29 -
