| |
調べてもわからないので、ご教授の方よろしくお願いいたします
A列 B列 C列 D列 E列 F列 G列
品名 材質 材寸 員数 **** **** **** ****
計画数 1000
入荷数 500
在庫 100 100+500-1000
**** **** **** **** ↑ この計算式を 横にAutoFILLしたい
Sub 進度表()
Dim i As Long
Dim Rcnt As Long, k As Long
Dim MyV As Variant
Dim RangeObje As Range
Dim FirstRanAddress As String
Dim rang As Range
Sheets("ﾏﾙｲﾁ集計").Activate
ActiveCell.CurrentRegion.Select
Selection.Copy
Sheets("進度１").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues
Range("A3000").End(xlUp).Select
Selection.EntireRow.Delete
For i = Cells(3000, 1).End(xlUp).Row To 4 Step -1
Rows(i).Insert (xlShiftDown)
Next i
For i = Cells(3000, 1).End(xlUp).Row To 4 Step -2
Rows(i).Insert (xlShiftDown)
Next i
Range("E:E").Select
Selection.Insert (xlshiftright)
Range("Ｆ:Ｆ").Select
Selection.Insert (xlshiftright)
Rows("1:1").Select
Selection.Insert
MyV = WorksheetFunction.Transpose(Array("入荷数", "在庫"))
Rcnt = Range("A65536").End(xlUp).Row
Range("E:E").ClearContents
For k = 4 To Rcnt Step 3
If Not IsEmpty(Cells(k, 1).Value) Then
Cells(k + 1, 5).Resize(2).Value = MyV
End If
Next k
Set RangeObje = Cells.Find("在庫")
If Not RangeObje Is Nothing Then
FirstRanAddress = RangeObje.Address
Do
RangeObje.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "=RC[-1]+R[-1]C-R[-2]C"
RangeObje.Offset(0, 2).Select
Selection.Copy
RangeObje.Offset(0, 3).Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Set RangeObje = Cells.FindNext(RangeObje)
Loop Until RangeObje Is Nothing Or RangeObje.Address = FirstRanAddress
End If
Columns("E:E").EntireColumn.AutoFit
Columns("a:a").EntireColumn.AutoFit
Columns("b:b").EntireColumn.AutoFit
Columns("c:c").EntireColumn.AutoFit
Range("A1").Select
Range(Range("A5000").End(xlUp).Offset(3, 0), Range("IV3").End(xlToLeft)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
Range("C8").Select
Cells.Select
Selection.RowHeight = 30
ActiveWindow.Zoom = 75
Rows("3:3").Select
Selection.Font.Bold = True
Selection.Font.Italic = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 4
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 4
End With
Range("L2").Select
Range("G3:IV3").Select
Selection.NumberFormatLocal = "m/d"
Range("a2").Select
ActiveCell.EntireRow.Select
Selection.Delete
End Sub
よろしくお願いします
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
