« October 2004 | Main

makuro

sub all()

call 表の形式変換()
call Macro1項目入力()
call Macro2削除と項目コピー()
call Macro2-2Errorも消すとき()
call Macro3セルの幅()
call 違う値になったら黄色()
call 仕上げ_色がわかった行を抽出()


end sub

Sub 表の形式変換()
Dim 範囲 As Range
Dim Gyo As Variant, Retsu As Variant, Cel As Variant
Dim i As Long

Dim cntRow As Long
Dim cntCol As Long
Dim Rng As Range

戻る:
'Gyo = Application.InputBox("ログ1ブロック分の行数を入力してください。", Type:=2)
Gyo = 13


If Gyo = 0 Then Exit Sub

If Gyo = "" Then
MsgBox "行数を入力してください"
GoTo 戻る
End If


'Retsu = Application.InputBox("ログデータの列数を入力してください。", Type:=2)
Retsu = 9


If Retsu = 0 Then Exit Sub

If Retsu = "" Then
MsgBox "表の列数を入力してください"
GoTo 戻る
End If

Set Rng = ActiveSheet.Range("A1").CurrentRegion

cntRow = Rng.Rows.Count - 4
cntCol = Rng.Columns.Count

Set Rng = Rng.Offset(4, 0) '※4行下にずらす
Set Rng = Rng.Resize(cntRow, cntCol) '※1行削る
' Rng.Copy Destination:=Sheets("Sheet2").Range("A2")

If Rng.Rows.Count Mod Gyo <> 0 Then
MsgBox "選択範囲と行数が一致しません。"
Exit Sub
End If


Cel = Gyo * Retsu

MsgBox Gyo & "、" & Cel

Worksheets.Add before:=Sheets(1)
Range("A2").Select

For i = 0 To Rng.Rows.Count * Gyo

ActiveCell.Offset(Int(i / Cel), i Mod Cel).Value = Rng.Cells(i + 1).Value

Next i

Cells.EntireColumn.AutoFit
End Sub

Sub Macro1項目入力()
'
' Macro1項目入力 Macro
' 測定値等を入力
'

'
Sheets(1).Select

Range("F2").Select
Selection.Copy
Range("I1").Select
ActiveSheet.Paste

Range("O2").Select
Selection.Copy
Range("R1").Select
ActiveSheet.Paste

Range("X2").Select
Application.CutCopyMode = False
Selection.Copy
Range("AA1").Select
ActiveSheet.Paste

Range("AG2").Select
Application.CutCopyMode = False
Selection.Copy
Range("AJ1").Select
ActiveSheet.Paste

ActiveWindow.SmallScroll ToRight:=17
Range("AP2").Select
Application.CutCopyMode = False
Selection.Copy
Range("AS1").Select
ActiveSheet.Paste

Range("AY2").Select
Application.CutCopyMode = False
Selection.Copy
Range("BB1").Select
ActiveSheet.Paste

Range("BH2").Select
Application.CutCopyMode = False
Selection.Copy
Range("BK1").Select
ActiveSheet.Paste

Range("BQ2").Select
Application.CutCopyMode = False
Selection.Copy
Range("BT1").Select
ActiveSheet.Paste

Range("BZ2").Select
Application.CutCopyMode = False
Selection.Copy
Range("CC1").Select
ActiveSheet.Paste

ActiveWindow.SmallScroll ToRight:=4

Range("CI2").Select
Application.CutCopyMode = False
Selection.Copy
Range("CL1").Select
ActiveSheet.Paste

Range("CR2").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll ToRight:=5
Range("CU1").Select
ActiveSheet.Paste

ActiveWindow.SmallScroll ToRight:=21

Range("DA2").Select
Application.CutCopyMode = False
Selection.Copy
Range("DD1").Select
ActiveSheet.Paste

Range("DJ2").Select
Application.CutCopyMode = False
Selection.Copy
Range("DM1").Select
ActiveSheet.Paste

Columns("B:B").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Range("B2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/1000"
Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B166")
Range("B2:B166").Select

Range("A1").Select
ActiveCell.FormulaR1C1 = "msec"
Range("B1").Select
ActiveCell.FormulaR1C1 = "sec"
Range("C1").Select
ActiveCell.FormulaR1C1 = "date"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Error"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Add"
Range("F1").Select
ActiveCell.FormulaR1C1 = "No"
Range("G1").Select
ActiveCell.FormulaR1C1 = "項目"
ActiveCell.Characters(1, 2).PhoneticCharacters = "コウモク"
Range("H1").Select
ActiveCell.FormulaR1C1 = "識別子"
ActiveCell.Characters(1, 3).PhoneticCharacters = "シキベツシ"

Range("I1").Select
ActiveCell.FormulaR1C1 = "■"
Range("A1:J1").Select
Selection.Copy
Range("A1").Select
Application.CutCopyMode = False
Selection.Copy


End Sub

Sub Macro2削除と項目コピー()
'
' Macro2削除と項目コピー Macro
'

'
Range("E:I,K:L,N:R,T:U,W:AA,AC:AD").Select
Range("AC1").Activate
ActiveWindow.SmallScroll ToRight:=22
ActiveWindow.SmallScroll Down:=-27
Range("E:I,K:L,N:R,T:U,W:AA,AC:AD,AF:AJ,AL:AM,AO:AS,AU:AV,AX:BB").Select
Range("AX1").Activate
ActiveWindow.LargeScroll ToRight:=1
ActiveWindow.SmallScroll ToRight:=-1
Range( _
"E:I,K:L,N:R,T:U,W:AA,AC:AD,AF:AJ,AL:AM,AO:AS,AU:AV,AX:BB,BD:BE,BG:BK,BM:BN,BP:BT,BV:BW,BY:CC,CE:CF"
_
).Select
Range("CE1").Activate
ActiveWindow.SmallScroll ToRight:=19
Range( _
"E:I,K:L,N:R,T:U,W:AA,AC:AD,AF:AJ,AL:AM,AO:AS,AU:AV,AX:BB,BD:BE,BG:BK,BM:BN,BP:BT,BV:BW,BY:CC,CE:CF,CH:CL,CN:CO,CQ:CU,CW:CX,CZ:DD,DF:DG"
_
).Select
Range("DF1").Activate
ActiveWindow.LargeScroll ToRight:=1
Range( _
"E:I,K:L,N:R,T:U,W:AA,AC:AD,AF:AJ,AL:AM,AO:AS,AU:AV,AX:BB,BD:BE,BG:BK,BM:BN,BP:BT,BV:BW,BY:CC,CE:CF,CH:CL,CN:CO,CQ:CU,CW:CX,CZ:DD,DF:DG,DI:DM"
_
).Select
Range("DI1").Activate
Selection.Borders(xlLeft).LineStyle = xlNone
Selection.Borders(xlRight).LineStyle = xlNone
Selection.Borders(xlTop).LineStyle = xlNone
Selection.Borders(xlBottom).LineStyle = xlNone
Selection.Delete Shift:=xlToLeft
Range("D1").Select
Selection.Copy
Range("F1").Select
ActiveSheet.Paste
Range("H1").Select
ActiveSheet.Paste
Range("J1").Select
ActiveSheet.Paste
Range("L1").Select
ActiveSheet.Paste
Range("N1").Select
ActiveSheet.Paste
Range("P1").Select
ActiveSheet.Paste
Range("R1").Select
ActiveSheet.Paste
Range("T1").Select
ActiveSheet.Paste
Range("V1").Select
ActiveSheet.Paste
Range("X1").Select
ActiveSheet.Paste
Range("Z1").Select
ActiveSheet.Paste
Range("AB1").Select
ActiveSheet.Paste
Range("AC1").Select
Application.CutCopyMode = False
Range("A1").Select
End Sub


Sub Macro2-2Errorも消すとき()
'
' Macro4Errorも消すとき Macro
'

'
Range("D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T,V:V,X:X,Z:Z,AB:AB").Select
Range("AB1").Activate
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub


Sub Macro3セルの幅()
'
' Macro5セルの幅 Macro
'

'
Columns("D:P").Select
Selection.ColumnWidth = 8.13
Columns("C:C").Select
Selection.ColumnWidth = 3.63
Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
End Sub

Sub 違う値になったら黄色()

'空白でなくなったら

Dim r '行
Dim f


r = Range("D5").End(xlDown).Row

For r = r To 5 Step -1

For f = 4 To 14

If Cells(r, f).Value <> Cells(r - 1, f).Value Then

Cells(r, f).Interior.Color = 65535 '違う値のセルを黄色に塗りつぶす
Cells(r - 1, f).Interior.Color = 13434879 '直前のセルを薄い黄色

End If


Next
Next
End Sub


Sub 仕上げ_色がわかった行を抽出()
Dim i As Long

Worksheets.Add before:=Sheets(1)

Sheets(2).UsedRange.Copy Sheets(1).Range("A1")
With Sheets(1).UsedRange
For i = 1 To .Columns.Count
.AutoFilter Field:=i, Operator:=xlFilterNoFill
Next
.Offset(1).Delete Shift:=xlUp
.AutoFilter
End With
End Sub

| | Comments (0) | TrackBack (0)

« October 2004 | Main