Sub 空白行削除1()
Dim i As Integer, endr As Integer
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Sheet3").Select
endr = Range("A31000").End(xlUp).Row + 1
For i = endr To 3 Step -1
If Cells(i, 1) = "" Then
Rows(i).Delete Shift:=xlUp
End If
Next
End Sub
|
Sub 空白行削除2()
Dim myRange As Range, myRange1 As Range
Application.ScreenUpdating = False
endr = Range("A31000").End(xlUp).Row + 1
Set myRange = Range(Cells(1, 1), Cells(endr, 2))
myRange.Columns(2) = 1
Set myRange1 = Range(Cells(2, 1), Cells(endr, 2))
myRange.AutoFilter
myRange1.AutoFilter Field:=1, Criteria1:=""
myRange1.SpecialCells(xlCellTypeVisible).ClearContents
Selection.AutoFilter
Cells.Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
Columns("B:B").ClearContents
End Sub
|
Sub 空白行削除3()
Dim myRange As Range
timck = Timer
Application.ScreenUpdating = False
endr = Range("A31000").End(xlUp).Row + 1
Set myRange = Range(Cells(1, 1), Cells(endr, 1))
myRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
|
Sub 行空け()
timck = Timer '◆測定スタート
行空け
Rows("33").Select
Selection.Insert Shift:=xlDown
データ記入
Cells(33, 2) = "AAAA": Cells(33, 3) = "BBBB": Cells(33, 4) = "CCCC"
Cells(33, 5) = "DDDD": Cells(33, 6) = "EEEE"
Cells(33, 1) = Date
MsgBox "マクロ処理時間⇒ " & Timer - timck & "秒", Title:="行空け"
End Sub
|
Sub 行空け高速()
timck = Timer '◆測定スタート
行空け
endr2 = Cells(10000, 1).End(xlUp).Row
Range(Cells(33, 1), Cells(endr2, 6)).Copy Range("A34")
データ記入
Cells(33, 2) = "AAAA": Cells(33, 3) = "BBBB": Cells(33, 4) = "CCCC"
Cells(33, 5) = "DDDD": Cells(33, 6) = "EEEE"
Cells(33, 1) = Date
MsgBox "マクロ処理時間⇒ " & Timer - timck & "秒", Title:="行空け高速"
End Sub
|
Sub 列削除1()
timck = Timer '◆測定スタート
データ整理
Columns("G").Delete Shift:=xlToLeft '調整後終値*カット
Columns("B").Insert Shift:=xlToRight 'B列を空ける
Columns("G:G").Select 'G列をB列へ
Selection.Copy
Range("B1").Select
ActiveSheet.Paste
Columns("G:G").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select
MsgBox "マクロ処理時間⇒ " & Timer - timck & "秒", Title:="列削除1"
End Sub
|
Sub 列削除2()
timck = Timer '◆測定スタート
endr2 = Cells(10000, 1).End(xlUp).Row
Range(Cells(32, 2), Cells(endr2, 6)).Copy Range("C32") 'B列以降をC列へ貼り付け
Range(Cells(32, 7), Cells(endr2, 7)).Copy Range("B32") 'G列をB列へ
Range(Cells(32, 7), Cells(endr2, 7)).ClearContents
Application.CutCopyMode = False
MsgBox "マクロ処理時間⇒ " & Timer - timck & "秒", Title:="列削除2"
End Sub
|
Sub テキスト取込1() Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "13TOKYO.CSV" End Sub |
Option Base 1Sub テキスト取込2()
Dim dat(5000, 15) As String
Dim txtpas As String, i As Integer
txtpas = ThisWorkbook.Path & "\" & "13TOKYO.CSV"
i = 1
Open txtpas For Input As #1
Do Until EOF(1)
Input #1, dat(i, 1), dat(i, 2), dat(i, 3), dat(i, 4), dat(i, 5), _
dat(i, 6), dat(i, 7), dat(i, 8), dat(i, 9), dat(i, 10), _
dat(i, 11), dat(i, 12), dat(i, 13), dat(i, 14), dat(i, 15)
i = i + 1
Loop
Close #1
Range(Cells(1, 1), Cells(i - 1, 15)).Value = dat
End Sub
|
Sub ダイアログ銘柄を保存()
Application.ScreenUpdating = False
Sheets("リアルタイム解析").Select
ReDim dbd(39, 6)
dbd = Range(Cells(43, 1), Cells(81, 6)).Value
filretu = 31
Call 保存場所指定 ’詳細省略
ファイル名
fmei = "優先Ｇ①-④リスト"
Open phn & "\" & fmei & ".txt" For Output As #1
For i = 1 To 39
For j = 1 To 6
Print #1, dbd(i, j)
Next j
Next i
Close #1
MsgBox "「" & fmei & "」を " & phn & "へ保存ました。"
End Sub
|
Sub ダイアログ銘柄取り込み()
Dim txtpas As String 'サンプルtxtファイル保存場所
Dim dat(39, 6) As String '2次配列宣言
Dim i As Integer 'カウンター
Sheets("リアルタイム解析").Select
Application.ScreenUpdating = False
ダイアログ表示
flt$ = "(*.txt),*.txt"
fff = Application.GetOpenFilename(flt$, 2, "ダイアログへ表示の銘柄を取り込み")
If fff = "False" Then
MsgBox "ファイルを１個指定して下さい"
End
End If
txtファイル取込
i = 1
Open fff For Input As #1
For i = 1 To 39
For j = 1 To 6
Input #1, dat(i, j)
Next j
Next i
Close #1
セルへ書き込み
For i = 1 To 39
For j = 1 To 6
Cells(i + 42, j) = dat(i, j)
Next j
Next i
End Sub
|
Sub コピー1()
timck = Timer
endr = Range("E30000").End(xlUp).Row
Range("A2").Select
ActiveCell.FormulaR1C1 = "=MID(RC[4],6,5)"
Range("A2").Select
Selection.Copy
Range(Cells(3, 1), Cells(endr, 1)).Select
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
End Sub
|
Sub コピー2()
endr = Range("E30000").End(xlUp).Row
Range("A2").Formula = "=MID(E2,6,5)"
Range(Cells(2, 1), Cells(endr, 1)).FillDown
End Sub
|
Sub コピー3()
endr = Range("E30000").End(xlUp).Row
Cells(2, 1).Formula = "=MID(E2,6,5)"
End Sub
|
Sub コピー4()
endr = Range("E30000").End(xlUp).Row
Range(Cells(2, 1), Cells(endr, 1)).Formula = "=MID(E2,6,5)"
End Sub
|
Sub 数値値化1()
Dim i As Integer
For i = 2 To endr
Cells(i, 1).Value = Cells(i, 1).Value
Next
Range("a2").Select
End Sub
|
Sub 数値値化2()
Dim myrang As Range
Set myrang = Range(Cells(2, 1), Cells(endr, 1))
myrang.Copy
myrang.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Range("a1").Select
Application.CutCopyMode = False
End Sub
|
Dim pth1 As String, su As IntegerSub システム1()
Dim myobj As Object, objFsy As Object, myfile As Object
su = 0: pth1 = ""
Columns("B:B").Clear
Set myobj = CreateObject("Shell.Application") _
.BrowseForFolder(0, "フォルダを選択してください", &H1)
If myobj Is Nothing Then
Exit Sub
End If
pth1 = myobj.Self.Path
Set myobj = Nothing
timck = Timer
Set objFsy = CreateObject("Scripting.FileSystemObject")
For Each myfile In objFsy.GetFolder(pth1).Files
If "db" <> Right(myfile, 2) Then
su = su + 1
Cells(su, 2).Value = myfile
End If
Next
MsgBox "マクロ処理時間⇒ " & Timer - timck & "秒", Title:="システム1"
MsgBox su & "個のファイル名を取得しました。"
|
Sub システム0()
Dim myobj As Object, pth As String, moz As String
su = 0: pth1 = ""
Columns("B:B").Clear
Set myobj = CreateObject("Shell.Application") _
.BrowseForFolder(0, "フォルダを選択してください", &H1)
If myobj Is Nothing Then
Exit Sub
End If
pth1 = myobj.Self.Path
Set myobj = Nothing
timck = Timer
pth = pth1 & "\"
moz = Dir(pth & "*" & "*")
Name pth & moz As pth & LCase(moz)
su = su + 1
Cells(su, 2).Value = pth & moz
Do Until moz = ""
moz = Dir()
If moz = "" Then Exit Do
Cells(su, 2).Value = pth & moz
Loop
MsgBox "マクロ処理時間⇒ " & Timer - timck & "秒", Title:="システム0"
MsgBox su & "個のファイル名を取得しました。"
|
Sub with例1()
UserForm1.Caption = "マクロ実行中：しばらくお待ち下さい"
UserForm1.Label1.BackColor = RGB(0, 153, 255)
UserForm1.Label1.TextAlign = fmTextAlignCenter
UserForm1.Label1.Font.Size = 14
UserForm1.Show 0
End Sub
---------------------------------------------------------
Sub with例2()
With UserForm1
.Caption = "マクロ実行中：しばらくお待ち下さい"
.Label1.BackColor = RGB(0, 153, 255)
.Label1.TextAlign = fmTextAlignCenter
.Label1.Font.Size = 14
End With
UserForm1.Show 0
End Sub
---------------------------------------------------------
Sub with例3()
With UserForm1
.Caption = "マクロ実行中：しばらくお待ち下さい"
With .Label1
.TextAlign = fmTextAlignCenter
.Font.Size = 14
End With
End With
UserForm1.Show 0
|
Sub 文字替え例1()
Cells(1, 1).Replace What:="-", Replacement:="ｰ", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=True, MatchByte:=True
End Sub
----------------------------------------------------------
Sub 文字替え例2()
Cells(1, 1).Replace What:="-", Replacement:="ｰ", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, MatchByte:=False
End Sub
|
Sub 変数削減1()
Dim evra As String, evrbas As String, evrc As Integer
For i = 1 To 300000
evra = Application.Version
evrb = Left(evra, 2)
evrc = Val(evrb)
Next
End Sub
------------------------------------------------------------
Sub 変数削減2()
Dim evrc As Integer
For i = 1 To 300000
evrc = Val(Left(Application.Version, 2))
Next
|
Sub 再計算()
Range("A101").Formula = "=SUM(A1:A100)"
For i = 1 To 100
For j = 1 To 100
Cells(j, 1) = Int((10000 - 1 + 1) * Rnd + 1)
Next
Next
End Sub
-------------------------------------------------------------
Sub 再計算a()
Range("A101").Formula = "=SUM(A1:A100)"
Application.Calculation = xlManual
For i = 1 To 100
For j = 1 To 100
Cells(j, 1) = Int((10000 - 1 + 1) * Rnd + 1)
Next
Next
|