Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

32428 / 76734

←次へ　｜　前へ→


	【49542】AutoFileを表のある部分まで

tetu - 07/6/10(日) 1:14 -


	引用なし

	パスワード

調べてもわからないので、ご教授の方よろしくお願いいたします
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
よろしくお願いします　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　　　

7 hits

▼

【49542】AutoFileを表のある部分まで tetu 07/6/10(日) 1:14

≪