https://ameblo.jp/ankokuneo/ SE 技術 備忘録です。自分用です。 ja Dim i As Long, tmp As Variant
For i = 2 To 22
tmp = Split(Cells(i, 1), " ")
Cells(i, 2) = tmp(0)
Cells(i, 3) = tmp(1)
Next i
End Sub

Sub Sample7()
Dim i As Long, tmp As Variant
For i = 2 To 6
tmp = Split(Cells(i, 1), vbLf)
Cells(i, 2) = tmp(0)
tmp = Split(tmp(1), "：")
Cells(i, 3) = tmp(1)
Next i
End Sub


こんなときは、Windows APIのSleepを使うと、CPUの使用率を抑えられます。

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Sample1()
Dim buf As String
Const LogFile As String = "C:\log\ex090310.log"
Open LogFile For Input As #1
Do Until EOF(1)
Line Input #1, buf
Debug.Print buf
Sleep 1
Loop
Close #1
End Sub ]]> https://ameblo.jp/ankokuneo/entry-11734085413.html Sun, 22 Dec 2013 14:05:15 +0900 Dim Target As String, i As Long, buf As String, c
Target = InputBox("年度を指定してください")
If Target = "" Then Exit Sub
For i = 2 To 9
If Left(Cells(i, 1), 4) = Target Then
buf = Target & "(" & Cells(i, 1).Address(0, 0) & ")" & vbCrLf
buf = buf & "----------" & vbCrLf
For Each c In Cells(i, 1).MergeArea
buf = buf & c.Address(0, 0) & vbCrLf
Next c
MsgBox buf
Exit For
End If
Next i
End Sub

Sub Sample4()
Dim buf As String
With Range("A1").MergeArea
buf = buf & .Rows.Count & "行" & vbCrLf
buf = buf & .Columns.Count & "列" & vbCrLf
buf = buf & .Count & "個" & vbCrLf
buf = buf & .Item(1).Address(0, 0) & ":左上" & vbCrLf
buf = buf & .Item(.Count).Address(0, 0) & ":右下"
End With
MsgBox buf
End Sub

Sub Sample5()
Dim Target As String, i As Long, buf As String, c
Target = InputBox("年度を指定してください")
If Target = "" Then Exit Sub
For i = 2 To 9
If Left(Cells(i, 1), 4) = Target Then
buf = Target & "年の受賞者は、" & vbCrLf
For Each c In Cells(i, 1).MergeArea
buf = buf & c.Offset(0, 1) & "さん" & vbCrLf
Next c
MsgBox buf
Exit For
End If
Next i
End Sub

Sub Sample1()
Range("A1:C4").Borders.LineStyle = True
End Sub


Sub Sample2()
If Application.Intersect(ActiveCell, Range("B2:D5")) Is Nothing Then
MsgBox ActiveCell.Address(False, False) & "は" & vbCrLf & _
"セル範囲B2:D5の外です"
Else
MsgBox ActiveCell.Address(False, False) & "は" & vbCrLf & _
"セル範囲B2:D5の中です"
End If
End Sub


Sub Sample4()
Dim myRange As AutoFilter
Set myRange = ActiveSheet.AutoFilter
If Not myRange Is Nothing Then
MsgBox "設定されています"
Else
MsgBox "設定されていません"
End If
End Sub


正解は「セルに設定されている表示形式によって異なる」です。
もし、元のセル範囲A1:A5に「文字列」の表示形式が設定されていた場合は、"001"や"002"などが、文字列として代入されます。このとき、"001"や"002"を、"1"や"2"など純粋な数値として表示したいのでしたら、代入するときに、表示形式も変更してやります。

Sub Sample2()
Dim i As Long
For i = 1 To 5
With Cells(i, 1)
.NumberFormat = "General"
.Value = Mid(.Value, 2)
End With
Next i
End Sub


あるいは、オートフィルタを設定したい表内の、どれか1つのセルを指定すれば、Excelが自動的に表の大きさを認識してくれますので、次のように書いてもOKです。

Range("A1").AutoFilter Field:=1, Criteria1:="田中"


Sub Sample2()
Dim PathName As String, FileName As String, pos As Long
pos = InStrRev("C:\Sample\Sub\Book1.xls", "\")
PathName = Left("C:\Sample\Sub\Book1.xls", pos)
FileName = Mid("C:\Sample\Sub\Book1.xls", pos + 1)
MsgBox PathName & vbCrLf & FileName
End Sub ]]> https://ameblo.jp/ankokuneo/entry-11734066983.html Sun, 22 Dec 2013 13:24:43 +0900
Sub Sample2()
Dim i As Long, buf As String
For i = 2 To 9
If Cells(i, 1).MergeCells Then
buf = buf & Cells(i, 1).Address(0, 0) & "-->結合されています" & vbCrLf
Else
buf = buf & Cells(i, 1).Address(0, 0) & "-->結合されていません" & vbCrLf
End If
Next i
MsgBox buf
End Sub ]]> https://ameblo.jp/ankokuneo/entry-11734066262.html Sun, 22 Dec 2013 13:23:02 +0900
Sub Sample6()
With Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0) = "2010/1/19"
.Offset(1, 1) = "佐山"
.Offset(1, 2) = 1234
End With
End Sub ]]> https://ameblo.jp/ankokuneo/entry-11734064837.html Sun, 22 Dec 2013 13:20:18 +0900 Endモードで見つかるセルの行番号を取得します。

Sub Sample3()
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "最終行は" & LastRow & "です"
End Sub ]]> https://ameblo.jp/ankokuneo/entry-11734064384.html Sun, 22 Dec 2013 13:18:58 +0900 Option Explicit
Private Const cnsSOUR = "C:\AAA\SAMPLE1.txt" ' 元ファイル
Private Const cnsDEST = "C:\BBB\SAMPLE2.txt" ' 先ファイル

' ファイルコピーのサンプル
Sub COPY_SAMPLE()

' ファイルをコピー
FileCopy cnsSOUR, cnsDEST
End Sub
]]> https://ameblo.jp/ankokuneo/entry-11733125806.html Fri, 20 Dec 2013 21:32:44 +0900
Dim range1 As Range

Set range1 = Range("B2:C5")
range1.Copy Destination:=Range("E2")

End Sub
]]> https://ameblo.jp/ankokuneo/entry-11733123487.html Fri, 20 Dec 2013 21:28:38 +0900 Range("C2") = Range("A1")
End Sub
]]> https://ameblo.jp/ankokuneo/entry-11733120412.html Fri, 20 Dec 2013 21:23:36 +0900 Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("C2")
End Sub
]]> https://ameblo.jp/ankokuneo/entry-11733119373.html Fri, 20 Dec 2013 21:21:58 +0900 1行目： Public Sub Sample_ExportAllModule_01()
2行目：
3行目： ' ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
4行目： ' 参照設定：
5行目： ' 「Microsoft Visual Basic for Application Extensibility」
6行目： ' ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
7行目：
8行目： ' このブックのVBProjectをオブジェクト変数に格納する。
9行目： Dim Obj As VBIDE.VBProject
10行目： Set Obj = ThisWorkbook.VBProject
11行目：
12行目： ' VBProjectに存在するコンポーネント数を変数に格納する。
13行目： Dim CompCnt As Long
14行目： CompCnt = Obj.VBComponents.Count
15行目：
16行目： ' エクスポート先のフォルダを決める。
17行目： Dim ExpDir As String
18行目： ExpDir = "C:\VBAModuleFile"
19行目：
20行目： ' VBProjectに存在するコンポーネントを一つずつ参照する。
21行目： Dim lp As Long
22行目： For lp = 1 To CompCnt
23行目： ' エクスポートするファイルの拡張子を決定する。
24行目： Dim str As String
25行目： Select Case Obj.VBComponents(lp).Type
26行目： Case 1
27行目： str = ".bas"
28行目： Case 2
29行目： str = ".frm"
30行目： Case Else
31行目： str = ".cls"
32行目： End Select
33行目：
34行目： ' エクスポートを実行する。
35行目： With Obj.VBComponents(lp)
36行目： .Export (ExpDir & "\" & .Name & str)
37行目： End With
38行目： Next
39行目：
40行目： ' オブジェクトを破棄する。
41行目： Set Obj = Nothing
42行目：
43行目： End Sub ]]> https://ameblo.jp/ankokuneo/entry-11733116563.html Fri, 20 Dec 2013 21:14:38 +0900