Sub ファイルの名前変更()
Path = Cells(1, 1) & "\" 'パスの場所
Cells(3, 1).Select ' A３セル以降変更
Do While ActiveCell <> ""
If ActiveCell.Offset(0, 1) <> "" Then
' 名前変更実施
Name Path & ActiveCell As Path & ActiveCell.Offset(0, 1)
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
＜サンプル＞VBAスタートすると、変更前から変更後に名前変更します。
↓変更前
↓結果
＜コード＞
Sub ファイル一覧()
Path = Cells(1, 1) & "\"
Filename = Dir(Path & "*", vbNormal)
Cells(3, 1).Select ' A3以降に検索結果貼り付け
ActiveCell = Filename
'ファイル内のbookがなくなるまで
Do While Filename <> ""
ActiveCell.Offset(1, 0).Select
Filename = Dir()
ActiveCell = Filename
Loop
End Sub
＜サンプル結果＞
＜コード＞
'データベースのシート：Sheets("基Data").Range("A1:Aj1000")
'検索条件：CriteriaRange:=Range("A1:l2") 調べたい項目を任意に変更可
'検索結果シートの場所：CopyToRange:=Range("p1:Ay1")
Private Sub Worksheet_Change(ByVal Target As Range) Sheets("基Data").Range("A1:Aj1000").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("A1:l2"), CopyToRange:=Range("p1:Ay1"), Unique:= _ False
| '検索結果シートに下記Vba貼り付け |
|
'データベースのシート：Sheets("基Data").Range("A1:Aj1000") '検索条件：CriteriaRange:=Range("A1:l2") '検索結果貼り付けシートの場所：CopyToRange:=Range("p1:Ay1") |
| Private Sub Worksheet_Change(ByVal Target As Range) |
| Sheets("基Data").Range("A1:Aj1000").AdvancedFilter Action:=xlFilterCopy, _ |
| CriteriaRange:=Range("A1:l2"), CopyToRange:=Range("p1:Ay1"), Unique:= _ |
| False |
| End Sub |
エクセルシートの画像オブジェクトをちまちま選択削除ではなく、
一気に削除したい。。。
＜コード＞
Sub アクティブシートの画像をすべて削除()
Dim oj1 As Shape 'oj1=削除したい画像定義付け
For Each oj1 In ActiveSheet.Shapes
oj1.Delete
Next oj1
End Sub
ちまちまコメント入れたり編集したりするのって、大変。。。
必要に迫られて作成。
＜コード＞
Sub コメントに置き換え()
Dim i As Long
Dim cl1, cl2 As String 'cl1＝コメント場所 、cl2＝コメント内容For i = 2 To Range("A65536").End(xlUp).Row
With Cells(i, 1)
cl1 = .Value
cl2 = .Offset(, 1).Value
End With
'コメント編集（リセットと書き換え）
With Range(cl1)
On Error Resume Next
.Comment.Delete
On Error GoTo 0
.AddComment (cl2)
' コメントのサイズ自動設定
With .Comment.Shape
. TextFrame.AutoSize = True
End With
End With
Next
End Sub
＜イメージ図＞
ちょいちょい作業の邪魔になるので、クイックツールバーに追加しました。
＜コード＞
Sub コメント表示()
Application.DisplayCommentIndicator = xlCommentAndIndicator
Range("A1").Select
End Sub
Sub コメント非表示()
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Range("A1").Select
End Sub
＜コード＞
shutdown.bat
@echo offshutdown.exe /s /t 0
必要に迫られて。。。
＜コード＞
Sub 同一項目縦から横列へ()
Dim i1, i2 As Range
Dim oj1, oj2 As String
'コードスタート位置
Set i1 = Range("A1")
'展開位置
Set i2 = Range("g1")
'同一項目縦から横列へ
Do Until i1.Value = ""
If oj1 = "" Then
oj1 = i1.Value
oj2 = i1.Offset(, 1).Value
ElseIf i1.Value = oj1 Then
oj2 = oj2 & "、" & i1.Offset(, 1).Value
Else
i2.Value = oj1
i2.Offset(, 1).Value = oj2
Set i2 = i2.Offset(1)
oj1 = i1.Value
oj2 = i1.Offset(, 1).Value
End If
Set i1 = i1.Offset(1)
Loop
If oj1 <> "" Then
i2.Value = oj1
i2.Offset(, 1).Value = oj2
End If
End Sub
[複数シートからデータを抽出]
ブック内の複数シートから、条件に合った検索値Dataを集結したい場合。
※複数シートは同じフォーマット前提です。
※下記コードは、A1～Dataがある場合なので、そうじゃない場合は変更必要です。
＜コード＞
Sub 複数シートからデータを抽出()
Dim i As Long
Dim 検索値 As Range
Worksheets("集約シート").Select
'A4行以降をシートリセット
Range(Range("A4"), Cells.SpecialCells(xlCellTypeLastCell)).EntireRow.Delete
On Error Resume Next
'ブック内のシート数カウント
For i = 2 To Worksheets.Count
For Each 検索値 In Range("1:1").SpecialCells(xlCellTypeConstants)
Worksheets(i).Range("A1").CurrentRegion.AutoFilter field:=検索値.Column, Criteria1:=検索値.Value
'Worksheets(i).UsedRange.AutoFilter field:=検索値.Column, Criteria1:=検索値.Value
Next
Worksheets(i).AutoFilter.Range.Offset(1).Copy Destination:=Range("A65536").End(xlUp).Offset(1)
Worksheets(i).AutoFilterMode = False
Next i
End Sub
＜サンプル＞↓
項目2,項目3,9月の検索したい値 が、検索値1 and 検索値2 and 300 の場合、
※セル A1~I1 に検索したい値を記載します（DataがA～I列の場合）。
検索結果はブック内の複数シートから、下記イメージで検索条件に合ったDataを集結します。
＜考え方＞
WEEKNUM関数を使えば、OK。
※週の基準は、日曜日スタートは１、2は月曜日スタートになります。
あとは、必要に応じて
＜コード＞
Dim input1 As Date, input2 As String
Do
input1 = InputBox("日付をinputして下さい。")
Loop Until IsDate(input1)
input2 = WorksheetFunction.WeekNum(input1, 2) _
- WorksheetFunction.WeekNum(DateSerial(Year(input1), Month(input1), 1), 2) + 1
MsgBox "inputされた日の月は 第 " & input2 & " 週目です"
End Sub
＜実行例＞
1月1日input時には、下記の表示となります。
-----------おまけ-------------------------------------------------------------------
＜コード＞
Sub 今日が本年の何週目かを表示する()
MsgBox "今日は 本年の " & DatePart("ww", Date) & " 週目です"
End Sub
今日（1月28日の場合）↓
[ユーザー定義で、年月日 + 曜日 表示ができますよ♪]
資料ファイルシートをコピーしようすると、見覚えのない名前定義が出てきて思うようにコピーできない時の対策。
対象bookを下記のvbs(名前の管理リセット.vbs)にドロップし不要定義を削除。
'名前の管理リセット.vbs’下記をテキストにコピーし 名前の管理リセット.vbs で保存。
If MsgBox("ドロップされたbook内の 名前の管理 をリセット(削除)します。" & vbCrLf & vbCrLf & _
"本当に良いですか？", vbOKCancel, "名前削除") = vbCancel Then WScript.QuitDim book1
Set objXls = CreateObject("Excel.Application")
objXls.Visible = True
For Each strFile In WScript.ArgumentsSet book1 = objXls.Workbooks.Open(strFile)
For Each Target In book1.Names
Target.Delete
Nextbook1.Save
book1.Close
Set book1 = NothingNext
objXls.Quit
MsgBox"削除完了しました。", , "処理完了"
少しでも繰り返し作業を楽に。
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim file1 As String, book1 As String
book1 = ActiveWorkbook.Name
file1 = Application.GetOpenFilename(FILEFILTER:="すべてのファイル,*.*")
If file1 = "False" Then Exit Sub
Workbooks.Open Filename:=file1
Cells.Copy
Workbooks(book1).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues
End Sub
Outlookでmail送信義務化の為、エクセルVBA送信で業務時間短縮図ります。
Sub エクセルからmail送信()
Dim Olobj As Outlook.Application
Dim mailobj As Outlook.MailItem
Dim i1 As Integer, i2 As Integer
Dim temp1 As String, temp2 As String
Set Olobj = CreateObject("Outlook.Application")
temp1 = Range("B4") '添付1
temp2 = Range("B5") '添付2
'作成したいmail選択
i1 = Range("G2") + 7 '開始番号
i2 = Range("I2") + 7 '終了番号
For i1 = i1 To i2
Set mailobj = Olobj.CreateItem(olMailItem)
mailobj.SentOnBehalfOfName = Range("B2") '差出人
mailobj.Subject = Range("B3") '件名
mailobj.To = Cells(i1, "B") 'TO
mailobj.Cc = Cells(i1, "C") 'CC
mailobj.Bcc = Cells(i1, "D") 'BCC
If temp1 <> "" Then
mailobj.Attachments.Add temp1
End If
If temp2 <> "" Then
mailobj.Attachments.Add temp2
End If
'本文
mailobj.Body = Cells(i1, "E") & vbCr _
& Cells(i1, "F") & vbCr & vbCr _
& Worksheets("文面").Range("A3")
mailobj.Display 'メール表示
'mailobj.send 'メール送信
Next
Set Olobj = Nothing
Set mailobj = Nothing
MsgBox "一旦、文面転記（内容チェック後、送信のこと!!）"
End Sub
