判別して記入

Sub 判別して記入() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim lastRow1 As Long Dim lastRow2 As Long Dim keyRange As Range Dim cell As Range Dim keyArray() As Variant Dim keyIndex As Long Dim labels() As String Dim labelIndex As Long Dim label As String ' シート1とシート2を設定 Set ws1 = ThisWorkbook.Sheets("Shee…

コピー転記してから色付け

Sub コピー転記してから色付け() Dim wsSource As Worksheet Dim wsDestination As Worksheet Dim wsKeywords As Worksheet Dim lastRowSource As Long Dim lastRowKeywords As Long Dim i As Long Dim j As Long Dim keyword As String ' Sheet1をソース、Sheet2を転記先、Sheet3をキーワードのシートに設定 Set wsSource = ThisWorkbook.Sheets("Sheet1") Set…

振分 (正規表現)

Sub UpdateDColumnWithRegex() Dim regex As Object Dim lastRow As Long Dim i As Long ' 正規表現オブジェクトを作成 Set regex = CreateObject("VBScript.RegExp") ' パターンを設定 regex.IgnoreCase = True regex.Global = True ' 最終行を取得 lastRow = Cells(Rows.Count, "C").End(xlUp).Row ' ループして条件に基づいてD列を更新 For i = 1 To lastRow ' 文字列か…

2つのKEYを比較し、お互いに存在しないKEYを別シートに抽出する

Sub 比較と記載1() ’Dictionaryにてremoveメソッド利用(ないものを削除パターン) Dim ws As Worksheet Dim lastRow1, lastRow2 As Long Dim aRange As Range, cRange As Range Dim aValue As Variant, cValue As Variant Dim compareColumnA As Range, compareColumnC As Range Dim resultDictA As Object, resultDictC As Object Dim i As Long ' 対…

ヒットする項目を抽出する

Sub TransferData() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim lastRow1 As Long Dim lastRow2 As Long Dim i As Long Dim j As Long Dim keyA As String Dim keyB As String Dim matchFound As Boolean ' Sheet1とSheet2を設定 Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws2 = ThisWorkbook.Sheets("Sheet2") ' Shee…

指定された日付から60日後の日付を計算

Sub 前日の日付を計算してセルに入力() Dim 検索日 As Date Dim 前日 As Date Dim 後日 As Date Dim フォーマット済み日付 As String Dim 休みの日 As Range ' セルA1に入力された日付を取得（ここではA1を例示しています） 検索日 = Range("A1").Value ' 休みの日をシート2のA列から取得 Set 休みの日 = Sheets("Sheet2").Range("A:A") ' 検索日の前日を計算 前日 = WorksheetFunction.WorkDay(検索日, -1, 休みの日) ' 検索日の後60日を計算…

ワークデイ関数を使って指定した日付の前日を計算

Sub 前日の日付を計算してセルに入力() Dim 検索日 As Date Dim 前日 As Date Dim フォーマット済み日付 As String Dim 休みの日 As Range ' セルA1に入力された日付を取得（ここではA1を例示しています） 検索日 = Range("A1").Value ' 休みの日をシート2のA列から取得 Set 休みの日 = Sheets("Sheet2").Range("A:A") ' 検索日の前日を計算 前日 = Application.WorksheetFunction.WorkDay(検索日, -1, 休みの日) ' yyyymmdd形式に日付を…

指定年、月と前後月 土日検索

Sub ExtractWeekendAndHolidayDatesByMonth(yearToSearch As Integer, monthToSearch As Integer) Dim startDate As Date Dim endDate As Date Dim currentDate As Variant Dim ws As Worksheet Dim rowNum As Long Dim holidayDates As Variant Dim i As Integer ' 新しいシートを作成します Set ws = ThisWorkbook.Sheets.Add(After:=…

毎月の土曜日と日曜日 抽出

Sub ExtractWeekendDates() Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim ws As Worksheet Dim rowNum As Long ' 新しいシートを作成します Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ws.Name = "WeekendDates" ' シートの名前を設定します ' ヘッダーを設定します ws.Range("A1"…

日本の休日を考慮して土曜日と日曜日を検索

Sub ExtractWeekendAndHolidayDatesByYear(yearToSearch As Integer) Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim ws As Worksheet Dim rowNum As Long Dim holidayDates As Variant Dim i As Integer ' 新しいシートを作成します Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbo…

クリア (列全体 EntireColumn)

Sub Sample() Range("B2:D5").EntireColumn.ClearEnd Sub

重複削除

Sub Sample() Range("A:C").RemoveDuplicates(Array(1, 2, 3))End Sub

条件 振り分け2

Sub UpdateDColumnWithRegex555() Dim regex As Object Dim lastRow As Long Dim i As Long '参照設定 Microsoft VBScript Regular Expressions 5.5 ' 正規表現オブジェクトを作成 Set regex = CreateObject("VBScript.RegExp") ' パターンを設定 regex.IgnoreCase = True regex.Global = True ' 最終行を取得 lastRow = Cells(Rows.Count, "C").End(xlUp)…

条件 振り分け

Sub UpdateDColumn() Dim lastRow As Long Dim i As Long ' 最終行を取得 lastRow = Cells(Rows.Count, "C").End(xlUp).Row ' ループして条件に基づいてD列を更新 For i = 2 To lastRow If InStr(1, Cells(i, "C").Value, "AAA") > 0 And InStr(1, Cells(i, "C").Value, "Z") > 0 Then Cells(i, "D").Value = "A111" ElseIf InStr(1, Cells(i, "C"…

sakuracolor kuro-2.col

'//sakuracolor kuro-2.col ; テキストエディタ色設定 Ver3 [SakuraColor]C[BRC]=1,1,ffff84,202020,0C[CAR]=1,0,ff8080,3a3a3a,0C[CBK]=0,0,f2f8f8,0e1616,0C[CMT]=1,0,cc9b6a,202020,0C[CTL]=0,0,c6c6c6,202020,0C[CVL]=0,0,ffc184,3a3a3a,0C[DFA]=0,0,202020,ffc184,0C[DFC]=0,0,202020,c0fdbd,0C[DFD]=0,0,202020,f2f8f8,0C[EBK]=0…

時間計測 サンプル

Sub Main() Dim executionTime As Double executionTime = MeasureExecutionTime() MsgBox "計測完了" & vbLf & "実行時間は" & Format(executionTime, "0.000秒") & "でした"End SubFunction MeasureExecutionTime() As Double Dim startTime As Double startTime = Timer ' ここに測定したい処理を挿入 Call AddSheetNamesToLastColumn2 MeasureExec…

重複削除し、抽出

Sub RemoveDuplicatesAndTransfer() Dim sourceSheet As Worksheet Dim targetSheet As Worksheet Dim lastRow As Long Dim i As Long Dim keyColumn As Range Dim keyRange As Range Dim uniqueKeys As Collection Dim key As Variant ' ソースシートとターゲットシートを設定 Set sourceSheet = ThisWorkbook.Sheets("Sheet1") ' ソースデータのシート…

処理を分岐

Sub MessagePrompt() Dim response As VbMsgBoxResult ' メッセージボックスを表示し、ユーザーからの応答を取得します response = MsgBox("処理を続行しますか？", vbYesNo + vbQuestion, "確認") ' ユーザーがYesを選択した場合の処理 If response = vbYes Then MsgBox "処理を続行します。" ' ここにYesを選択した場合の処理を記述します Else ' ユーザーがNoを選択した場合の処理 MsgBox "処理を中止します。" ' ここにNoを選択した場合の処理を記述します…

time計測

'time計測Dim ST As DoubleST = Timer '処理時間の取得Debug.Print Timer - STMsgBox "取得が完了しました" & vbLf & "実行時間は" & Format(Timer - ST, "0.000秒") & "でした" '//-------------------- Debug.Print Now() & Right(Format(Timer, "0.00"), 3)Debug.Print Format(Now(), "YYYY/MM/DD HH:MM:SS") & Right(Format(Timer, "0.00"), 3)Debu…

配列を使用して日付を変換

Sub ConvertDateFormatWithArray() Dim lastRow As Long Dim dateValues As Variant Dim convertedDates() As Variant Dim i As Long Dim yyyy As String Dim mm As String Dim dd As String ' 最終行を取得 lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' A列の値を配列に読み込む dateValues = Range("A1:A" & lastRow).Value ' 出力用の配列…

バッチファイル内でPowerShellを利用してウィンドウの不透明度を88%に設定

@echo off set "WindowTitle=MyWindowTitle"set "Opacity=88" powershell.exe -Command "$signature='[DllImport(\"user32.dll\")]public static extern bool SetLayeredWindowAttributes(IntPtr hwnd, uint crKey, byte bAlpha, uint dwFlags);';$winapi=Add-Type -MemberDefinition $signature -Name LayeredWindow -Name…

分岐確認 サンプル

Sub CreateResultFile() ’セルC2が空白でない場合にはCSVファイルが作成し、かつセルC2が空白の場合にはテキストファイルが作成 Dim searchDate As String Dim fileName As String Dim filePath As String Dim fileContent As String Dim ws As Worksheet Dim cellC2 As Range ' 検索日の取得 searchDate = Format(Date, "yyyymmdd") ' ファイル名の作成 fileName = "対象なし_" & searchDa…

Outlook VBAを使用して、特定の受信メールの添付ファイルを指定したフォルダにダウンロード

'//-------------------------------------------------------- Sub SaveAttachmentsToFolder() Dim olFolder As Outlook.MAPIFolder Dim olItem As Object Dim olAttachment As Outlook.Attachment Dim saveFolder As String ' 受信メールフォルダを指定します。必要に応じて変更してください。 Set olFolder = Application.GetNamespace("MAPI").GetDefau…

検索結果シートをPDFとして保存

Sub SaveSearchResultAsPDF() Dim searchDate As String Dim fileName As String Dim filePath As String ' 検索日の取得 searchDate = Format(Date, "yyyymmdd") ' ファイル名の作成 fileName = "検索結果_" & searchDate & ".pdf" ' ファイルパスの作成（保存先を適切な場所に変更してください） filePath = ThisWorkbook.Path & "\" & fileName ' PDFとしてシートを保存 Sheets("検…

検索結果が抽出されなかった場合、テキストファイルを作成し保存する

Sub CreateResultTextFile() Dim searchDate As String Dim fileName As String Dim filePath As String Dim fileContent As String ' 検索日の取得 searchDate = Format(Date, "yyyymmdd") ' ファイル名の作成 fileName = "対象なし_" & searchDate & ".txt" ' ファイルパスの作成（保存先を適切な場所に変更してください） filePath = ThisWorkbook.Path & "\" & fileName…

タスクスケジューラー 実行するVBSファイルとマクロファイル、マクロ名の設定

■プログラム/スクリプト：VBSファイルパス Dim excelApp,macro file = WScript.Arguments(0)macro = WScript.Arguments(1) Set excelApp = CreateObject("Excel.Application") excelApp.Visible = False 'Excelを非表示にするexcelApp.DisplayAlerts = False 'ポップアップメッセージを非表示にするexcelApp.AutomationSecurity = 1 'マクロを有効にする 'Excelファイルを読み取り専用で開くex…

Excelの起動オプション

起動画面（スプラッシュウィンドウ）を表示しない ”C:\Program Files (x86)\Microsoft Office\root\Office16\EXCEL.EXE” /e ---オプション---ブックのパス ファイル名 Excel を起動し、指定されたファイルを開く。 excel.exe "c:\My Folder\book1.xlsx"/x Excel の新しいインスタンスを (別プロセスで) 起動。 excel.exe /x "c:\My Folder\book1.xlsx"/r 指定されたブックを読み取り専用で開く。 excel.exe /r "c:\My Folder…

バッチファイルをタスクバーにピン留めする方法

バッチファイルのショットカットのリンク先の先頭に 「cmd.exe /c 」をつけて、適用 ※「cmd.exe /c 」のcの後ろには半角スペース

値のみ貼り付け

Sub 値のみ貼り付け() ' セルA1をコピー Worksheets("Sheet1").Range("A1").Copy ' セルB1に値のみを貼り付け Worksheets("Sheet2").Range("B1").PasteSpecial Paste:=xlPasteValues ' コピー状態を解除 Application.CutCopyMode = FalseEnd Sub

日付を付けてcsv保存

Sub SaveCSVWithDate() Dim savePath As String Dim fileName As String Dim currentDate As String ' 現在の日付を取得し、yyyymmdd形式にフォーマットする currentDate = Format(Date, "yyyymmdd") ' 保存先のパスを指定 savePath = "C:\YourFolderPath\" ' 保存したいフォルダのパスに変更してください ' ファイル名を指定 fileName = "YourFileName_" & currentDate & ".csv" ' "You…

転記サンプル

Sub 転記() Dim LastRow As Long Dim i As Long ' Sheet1の最終行を取得 LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row ' データ転記 For i = 2 To LastRow ' 1行目はヘッダーとしてスキップ ' Sheet1からSheet2へ値のみ転記 Sheets("Sheet2").Cells(i, 3).Value = Sheets("Sheet1").Cells(i, 1).Value ' Sheet1のA列からSheet2のC列へ Sheets("Sheet…

作成するピボットテーブルが「現在のピボットテーブルの書式」または「従来のピボットテーブルの書式」のどちらであるかを選択

Sub CreatePivotTableWithPrompt() Dim ws As Worksheet Dim pt As PivotTable Dim pc As PivotCache Dim rngData As Range Dim rngDest As Range Dim response As VbMsgBoxResult ' データ範囲を指定します。適切に変更してください。 Set ws = ThisWorkbook.Worksheets("Sheet1") Set rngData = ws.Range("A1:D100") ' データの範囲を指定 ' ユーザーに確認メッセージを表…

従来のピボットテーブルの書式でピボットテーブルを作成

Sub CreatePivotTableWithFormat() Dim ws As Worksheet Dim pt As PivotTable Dim pc As PivotCache Dim rngData As Range Dim rngDest As Range ' データ範囲を指定します。適切に変更してください。 Set ws = ThisWorkbook.Worksheets("Sheet1") Set rngData = ws.Range("A1:D100") ' データの範囲を指定 ' ピボットテーブルを配置する場所を指定します。適切に変更してください。 Set rngDes…

Sheet1からSheet2に列AからGのデータをコピーする方法の例

Sub CopyData1() Dim sourceSheet As Worksheet Dim targetSheet As Worksheet Dim lastRow As Long ' ソースシート（コピー元のシート）とターゲットシート（コピー先のシート）を設定 Set sourceSheet = ThisWorkbook.Sheets("Sheet1") Set targetSheet = ThisWorkbook.Sheets("Sheet2") ' ソースシートの最終行を取得 lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "…

編集結果を転記する A列の7項目ごとの 繰り返し vba

Sub 編集結果を転記する()'売上見込み編集 Dim sourceSheet As Worksheet Dim targetSheet As Worksheet Dim lastRow As Long Dim i As Long Dim targetRow As Long Dim targetColumn As Long Dim sourceColumns As Long '編集結果シート初期化 Sheets("編集結果").Select Rows("2:2").Select Selection.Delete Shift:=xlUp ' データが格納されているシートを設定 Set sourc…

販売利益データ編集 + PDF保存

Option ExplicitSub sheet初期化() Columns("A:H").Select Selection.ClearContents Range("A1").SelectEnd SubSub 売上編集結果()'出品した商品 販売利益データのデータから編集 Dim sourceSheet As Worksheet Dim targetSheet As Worksheet Dim lastRow As Long Dim i As Long Dim targetRow As Long '編集結果シート初期化 Sheets("編集結果.").Select Rows("2:2").Se…

Excelシート 目次作成

Sub CreateTableOfContents() Dim ws As Worksheet Dim tocSheet As Worksheet Dim rowNum As Integer Dim sheetNum As Integer ' 新しいシートを作成して目次を作成 Set tocSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) tocSheet.Name = "目次" tocSheet.Range("B1").Value = "目次" rowNum = 2 s…

■

Option ExplicitSub 最短納期抽出() Dim wsSource As Worksheet Dim wsDestination As Worksheet Dim lastRowSource As Long Dim lastRowDest As Long Dim sourceRange As Range Dim destRange As Range Dim dict As Object Dim key As Variant Dim rowNum As Long ' ソースシートとデスティネーションシートを設定 Set wsSource = ThisWorkbook.Sheets(…

ひな形の隣にシート追加

Sub AddSheetWithDate() Dim ws As Worksheet Dim newSheet As Worksheet Dim templateSheet As Worksheet Dim sheetName As String Dim templateFound As Boolean ' 今日の日付をMMDD形式で取得 sheetName = Format(Date, "mmdd") ' すでに同じ名前のシートが存在する場合は、終了 For Each ws In ThisWorkbook.Sheets If ws.Name = sheetName Then MsgBox "…

vbsで Excelvba(.xlsm)起動

Dim FilePathFilePath = "D:\ThinkpadMark3\自学\filename変更_bat類\.xlsm\繰り返しCopy.xlsm" Dim appSet app = CreateObject("Excel.Application")app.Visible = trueapp.Workbooks.Open FilePathapp.Run "Module1.繰り返し" app.DisplayAlerts = False app.Workbooks.Open FilePath.saveapp.QuitSet app = Nothing

昨日の日付をセルに出力

Sub 昨日の日付をセルに出力() Dim 昨日 As Date Dim yyyymmdd As String ' 昨日の日付を計算 昨日 = Date - 1 ' yyyymmdd形式で文字列に変換 yyyymmdd = Format(昨日, "yyyymmdd") ' セルA1に文字列を出力 Sheets("sheet1").Range("A1").Value = yyyymmddEnd Sub

Excel形式でファイルを保存/圧縮ファイル作成

Sub ExportToExcelAndCompress() Dim xlApp As Object Dim xlBook As Object Dim rs As Recordset Dim strSQL As String Dim filePath As String ' エクスポートするデータのクエリを指定 strSQL = "SELECT * FROM YourTableName" ' データをレコードセットとして取得 Set rs = CurrentDb.OpenRecordset(strSQL) ' 新しいExcelアプリケーションを開始 Set xlApp = CreateObje…

CSV形式でエクスポートし、その後ZIP形式で圧縮

Sub ExportAndCompressData() Dim rs As Recordset Dim db As Database Dim strSQL As String Dim exportPath As String Dim zipPath As String Dim zipFileName As String Dim shellApp As Object ' エクスポートするデータのクエリを指定 strSQL = "SELECT * FROM YourTableName" ' エクスポート先のフォルダーとファイル名を指定 exportPath = "C:\ExportFolder\"…

データをバッチ処理し、複数の小さなファイルに分割するサンプルコード(1,000単位ごと)

Sub ExportDataInBatches() Dim rs As Recordset Dim db As Database Dim strSQL As String Dim batchCount As Integer Dim batchSize As Integer Dim recordCount As Long Dim i As Integer ' バッチサイズとエクスポートするデータの数を設定 batchSize = 1000 ' 1つのバッチのサイズ strSQL = "SELECT * FROM YourTableName" ' エクスポートするデータのクエリを指定 Set db…

ExcelExport Access

Private Sub ExcelExport() '変数宣言Dim srchXls As String 'Excelエクスポート先のファイルパスsrchXls = "D:\保存先\" & "Export_" & Format(Date, "yymmdd") & ".xlsx" 'Excelファイルの出力DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "クエリ名", srchXls, True, "出力結果" 'Excelファイルをエクスポートした旨を通知する。MsgBox "Excelをエクスポートしました。"…

サブクエリ抽出

Option Explicit Sub CreateSQLReview() Dim conn As Object Dim rs As Object Dim strSQL As String Dim strOutput As String Dim i As Integer ' Access データベースへの接続 Set conn = CreateObject("ADODB.Connection") conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\ThinkpadMark3\自学\filename変更_bat類\.accdb\…

HAVING Count サンプル

'//ordersテーブルから顧客ごとの注文数を計算し、その注文数が3以上の顧客のみを抽出 SELECT customer_id, COUNT(*) AS order_countFROM ordersGROUP BY customer_idHAVING COUNT(*) >= 3; '//各部署の平均給与を計算し、平均給与よりも高い給与を持つ部署のみを抽出 SELECT department_id, AVG(salary) AS avg_salaryFROM employeesGROUP BY department_idHAVING AVG(salary) > 50000;’ ’//各都市の顧…

サブクエリ サンプル

'//サブクエリ サンプル-----------In(SELECT フィールド名1 FROM Q_名称 WHERE( フィールド名2 = 条件1 And フィールド名3 = 条件2 ) OR( フィールド名2 = 条件3 And フィールド名3 = 条件4 ) OR( フィールド名2 = 条件5 And フィールド名3 = 条件6 ) OR( フィールド名2 = 条件6 And フィールド名3 = 条件7 ) OR( フィールド名2 = 条件7 And フィールド名3 = 条件8 ) GROUP BY フィールド名1 HAVING Count(1) = 5) '//クエリ サンプル------…

Excel→Accessデータ抽出(DAOパラメータ条件ある場合)

Sub Excel→Accessデータ抽出2() Dim AccessApp As Object Dim AccessDb As Object Dim AccessQuery As Object Dim AccessRecordset As Object Dim ExcelApp As Object Dim ExcelSheet As Object Dim AccessPath As String Dim i As Long ' Accessデータベースのパスを取得 AccessPath = Sheets("Sheet1").Range("B2").Value ' Accessアプリケーション…

Excel→Accessデータ抽出(ADO利用、パラメータ条件ある場合)

Sub Excel→Accessデータ抽出() Dim AccessPath As String Dim AccessQuery As String Dim ConnectionString As String Dim Conn As Object Dim RS As Object Dim ExcelApp As Object Dim ExcelSheet As Object Dim i As Long Dim paramValue1 As String Dim paramValue2 As String Dim paramValue3 As String Dim paramValue4 As…

最新単価抽出(KEYが3つの場合) VBA

Sub 最新単価抽出() Dim wsData As Worksheet Dim wsOutput As Worksheet Dim lastRow As Long Dim partNumCol As Long, dimCol As Long, bcCol As Long, dateCol As Long, priceCol As Long Dim key As Variant Dim priceDict As Object Dim maxDateDict As Object Dim i As Long Dim outputRow As Long ' データが含まれるシートの設定 Set ws…

部品ごとに最新価格を抽出(KEYが一つの場合) VBA

Sub ExtractLatestPrice() Dim ws As Worksheet Dim lastRow As Long Dim partNumbers As Variant Dim uniquePartNumbers As Variant Dim partNumber As Variant Dim i As Long Dim maxDate As Date Dim latestPrice As Double Dim outputRow As Long ' データが入力されているシートを指定します Set ws = ThisWorkbook.Sheets("Sheet2") ' She…

最新のもの抽出(KEYが4つの場合) VBA

Sub ExtractLatestPrices4() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim lastRow As Long Dim partNumbers As Object Dim key As String Dim maxDate As Date Dim latestPrice As Double Dim newData() As Variant Dim i As Long Dim newRow As Long ' ソースとなるワークシートを設定 Set wsSource = ThisWorkbook.Sheets(…

シート連番 追加版(call) VBA

Sub シート連番() Dim ws As Worksheet Dim i As Integer i = 1 For Each ws In ThisWorkbook.Sheets If Left(ws.Name, 2) = "最新" Then ws.Name = Left(ws.Name, 4) & Format(i, "00") i = i + 1 End If Next wsEnd Sub

yyyymmdd形式からyyyy/mm/dd形式に変換 vba

Sub日付け変更 () Dim cell As Range Dim originalDate As String Dim convertedDate As String ' 変換したいセルの範囲を指定 For Each cell In Selection ' セルの値を取得 originalDate = cell.Value ' yyyymmdd形式からyyyy/mm/dd形式に変換 If Len(originalDate) = 8 Then convertedDate = Left(originalDate, 4) & "/" & Mid(originalDate, 5, 2) & "/" …

フォルダ内の全シート1を取りまとめる

Sub フォルダ内の全シート1を取りまとめる() Dim フォルダパス As String Dim 対象ファイル As String Dim 対象ブック As Workbook Dim 一時ブック As Workbook Dim シート As Worksheet Dim 合成シート As Worksheet Dim 最終行 As Long Application.ScreenUpdating = False '新しいワークブックを作成 Set 一時ブック = Workbooks.Add Set 合成シート = 一時ブック.Sheets(1) '合成シートの行数を初期化 最終行 = 1 '対象フ…

フォルダ内の全集計ファイルを取りまとめる

Option Explicit Sub フォルダ内の全集計ファイルを取りまとめる() Dim フォルダパス As String Dim 対象ファイル As String Dim 対象ブック As Workbook Dim 一時ブック As Workbook Dim シート As Worksheet Dim 合成シート As Worksheet Dim 最終行 As Long Dim 集計ファイル数 As Integer Application.ScreenUpdating = False ' 新しいワークブックを作成 Set 一時ブック = Workbooks.Add Set 合成シート = …

ExcelからAccessクエリ取り込み

Sub ExtractDataFromAccess() Dim conn As Object ' ADO Connection Dim rs As Object ' ADO Recordset Dim strConn As String Dim strSQL As String Dim i As Integer Dim j As Integer ' Access データベースへの接続文字列を設定（IDとパスワードあり） strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\path\to\your\database.accdb;…

HighlightLastNonEmptyCell

Sub HighlightLastNonEmptyCell() Dim rng As Range Dim cell As Range Dim lastNonEmptyCell As Range Dim inputRange As Range ' ユーザーにセル範囲を指定させるための InputBox を表示 On Error Resume Next Set inputRange = Application.InputBox("セル範囲を指定してください。例：A1:E10", "セル範囲選択", Type:=8) On Error GoTo 0 If inputRange Is Nothing …

空白でない一番右のセル値を抽出 VBA(自作関数)

Function rightcellvalue(rng As Range) As Variant Dim lastCell As Range Dim ws As Worksheet ' シートをアクティブにする（指定範囲がどのシートにあるかを確認） Set ws = rng.Worksheet ws.Activate ' 指定範囲内の最後のセルを取得 Set lastCell = rng.Cells(rng.Cells.Count) ' 最も右側の空でないセルの値を取得 While lastCell.Value = "" And Not lastCell Is Nothing Set last…

拡張子毎に振り分け bat

@echo off::フォルダー内list→log化dir /b *.* > log.log ::logにあるリストのみ移動for /f %%a in (log.log) do move "%%a" %%~xaexit

VBE_color_レジストリ値

[個人仕様]［CodeBackColors］ 4 0 0 7 6 4 4 4 0 0 0 0 0 0 0 0 ［CodeForeColors］ 7 0 5 0 1 2 11 2 0 0 0 0 0 0 0 0 [マトリクス仕様]［CodeBackColors］ 4 0 1 7 6 4 4 4 4 4 0 0 0 0 0 0 ［CodeForeColors］ 9 0 15 0 1 2 1 9 9 7 0 0 0 0 0 0

スケール    拡大/縮小 (参考)

スケール 拡大/縮小 第一候補 第二候補拡大 A4→A3 140% 141%B5→B4A5→A4A4→B4 122% A5→B5B4→A3 114% 115%B5→A4等倍 - 100% 縮小 A4→B5 84% 87%A3→B4B5→A5 81% 82%B4→A4A4→A5 70% 71%B4→B5A3→A4

Excelのピボットテーブルで作成したような集計表から、リスト形式へ

Sub CreateOriginalTableFromPivotTable() Dim pt As PivotTable Dim wsSource As Worksheet Dim wsDestination As Worksheet Dim rngSource As Range Dim rngDestination As Range Dim srcRow As Long Dim destRow As Long ' ピボットテーブルがあるシートの参照 Set wsSource = ThisWorkbook.Sheets("PivotTableSheet") ' ピボットテーブルの参照 Set …

Key値に対する重複を1つのセルにまとめる

Sub 結合() Dim ws As Worksheet Dim lastRow As Long Dim dict As Object Dim key As String Dim i As Long Dim result As String ' 新しいディクショナリを作成 Set dict = CreateObject("Scripting.Dictionary") ' データがあるシートを指定 Set ws = ThisWorkbook.Sheets("Sheet1") ' 最終行を取得 lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row…

Excelコメント類のメンテ

Sub ResetComments() Dim cmt As Comment 'すべてのコメントをループして削除する For Each cmt In ActiveSheet.Comments cmt.Delete Next cmtEnd Sub '//---------------------------------------------------------------'エクセルの行と列を入れ変えたシートを作る(行列入れ替え)'---------------------------------------------------------------//Sub 行と列を入れ変えたシート…

■

Sub 職場名と在庫数を転記する() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim lastRow1 As Long Dim lastRow2 As Long Dim i As Long, j As Long Dim foundMatch As Boolean Dim maxStock As Long Dim maxStockLocation As String Dim secondMaxStock As Long Dim secondMaxStockLocation As String Dim thirdMaxStock As Long Dim …

power BI 自動立ち上げ、ダウンロード

' 現在の日付を取得Dim currentDatecurrentDate = Year(Date) & "-" & Right("0" & Month(Date), 2) & "-" & Right("0" & Day(Date), 2) ' 保存先フォルダを指定Dim saveFolderPathsaveFolderPath = "C:\Your\Custom\Folder\Path\" ' Internet Explorerのインスタンスを作成するSet objIE = CreateObject("InternetExplorer.Application") ' Power BIのURLに…

バッチで自動立ち上げ

''vbs------------ ' Create Internet Explorer ObjectSet IE = CreateObject("InternetExplorer.Application") ' Set visibility to true to make it visible, false to hide itIE.Visible = True ' Navigate to the specified webpageIE.Navigate "https://www.example.com" ' ここに指定のページのURLを入力します ' Loop until the page…

バッチで、Excelを起動して指定したファイルを開く

@echo off rem Excelを起動して指定したファイルを開くstart excel "C:\path\to\your\file.xlsx" rem 起動時にウィンドウを最大化する場合rem start /max excel "C:\path\to\your\file.xlsx" rem 起動時にウィンドウを最小化する場合rem start /min excel "C:\path\to\your\file.xlsx" exit

結合シート作成

Sub 結合シート作成() Dim ws As Worksheet Dim combinedSheet As Worksheet Dim lastRow As Long Dim combinedRow As Long ' 新しいシートを作成して、結合先として使用します Set combinedSheet = ThisWorkbook.Sheets.Add(After:= _ ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) combinedSheet.Name = "結合シート" ' 最初のシートからデータをコピーして貼り付けます For Each…

選択したエクセルシートのみpdf vba

Sub ExportSelectedSheetsToPDF() Dim selectedSheet As Worksheet Dim savePath As String ' PDFを保存するフォルダのパスを指定します savePath = "C:\Users\YourUsername\Documents\" ' 適切なパスに置き換えてください ' 選択したシートをPDFにエクスポートします For Each selectedSheet In ActiveWindow.SelectedSheets selectedSheet.ExportAsFixedFormat Type:=xlTypePD…

pdfファイル 複製 vbs

Option Explicit ' ドロップアウトするフォルダを指定しますConst sourceFolder = "Z:\Work\" ' 出力フォルダを指定しますConst outputFolder = "Z:\Work\" Dim objFSO, objFolder, objFileDim shell, newName, fileName ' File System Object を作成しますSet objFSO = CreateObject("Scripting.FileSystemObject") ' 出力フォルダが存在しない場合は作成しますIf Not objFSO.FolderE…

セルに、今日の日を入力(YYYYMMDD)

Sub InsertTodayDate() Range("A1").Value = Format(Date, "YYYYMMDD")End Sub

罫線 案(サンプル)

Sub 罫線案()Dim st As WorksheetSet st = Worksheets("sheet1") Dim myRegion As VariantmyRegion = Range("A1").CurrentRegion Dim z, x, j As LongFor j = LBound(myRegion, 2) To UBound(myRegion, 2) z = st.Cells(Rows.Count, j).End(xlUp).rowx = st.Cells(1, j).End(xlDown).row Dim i As Long For i = z To x Step -1…

ファイル名、転記(拡張子なし）VBA_Ver.

Sub WriteFileNamesToSheet() ' フォルダのパスを指定 Dim folderPath As String folderPath = "Z:\Work" ' 出力シートを指定 Dim outputSheet As Worksheet Set outputSheet = ThisWorkbook.Sheets("Sheet1") ' ファイル一覧を取得 Dim objFSO As Object Set objFSO = CreateObject("Scripting.FileSystemObject") Dim objFolder As Object Set objFol…

ファイル名（拡張子なし）を出力ファイルに書き込む vbs

' フォルダのパスを指定folderPath = "Z:\Work" ' 出力ファイルの保存場所とファイル名を指定 ’desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")outputFolderPath = "C:\Custom\Path"outputFileName = "output.txt" ' ファイル一覧を取得Set objFSO = CreateObject("Scripting.FileSystemObject")Set objFolder = objFSO.GetFolder(folderPa…

ツリー階層図2

Option Explicit Private Tree As Worksheet, 作業sheet As Worksheet, 階層図 As WorksheetPrivate Treeの行末 As Long, 表示行 As Long Sub Tree図() Dim 行1 As Long, 行2 As Long, 行末 As Long Set Tree = Worksheets("Tree") Set 作業sheet = Worksheets("作業sheet") Set 階層図 = Worksheets("階層図") 作業sheet.UsedRange.Clear 階層図.UsedRange…

親子ツリー階層図

Option Explicit Private 親子 As Worksheet, 作業用 As Worksheet, 階層図 As WorksheetPrivate 親子の行末 As Long, 表示行 As Long Sub SwapColumnsAandB() Dim ws As Worksheet Dim lastRow As Long Dim temp As Variant Dim i As Long ' Set a reference to the "親子" worksheet Set ws = ThisWorkbook.Worksheets("親子") ' Find the las…

ステータスバーに進捗表示

Sub ステータスバーに進捗表示() Dim i,r As Long r = 1000 ' 検索値 For i = 0 To r Application.StatusBar = "進捗状況：" & i & "/" & r & "(" & (i / r) * 100 & "%)" Next Application.StatusBar = False End Sub

Excel-log履歴テキスト保存する

Option Explicit ’PERSONAL.XLSBのThisWorkbookへ保存 '// Excelのイベント検知Dim WithEvents x As Application '// PERSONAL.XLSBが開いたときPrivate Sub Workbook_Open() '// Excelアプリケーションのイベントを検知する Set x = ApplicationEnd Sub '// ブックが開いた場合Private Sub x_WorkbookOpen(ByVal Wb As Workbook) Call OutputHistory(Wb, "Open")End Sub…

ステータスバー

Sub ステータスバー1() Dim i As Long For i = 1 To 500 Application.StatusBar = i & "回目の処理をしています..." Next i Application.StatusBar = FalseEnd Sub Sub ステータスバー2() ThisWorkbook.Worksheets("Sheet1").Activate Application.Wait [Now() + "00:00:01"] Application.StatusBar = "処理中・・・ 10％ : ■□□□□□□□□□" Application.Wait [N…

処理時間計測

'vba起動の経過時間、関数の宣言'Declare Function GetTickCount Lib "kernel32.dll" () As Long '←32bitDeclare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long '←64bit Sub 処理時間計測()stTimer = GetTickCount '//--測定する処理------ Test '--------------------// endTimer = GetTickCount Debug.Print "経過時間 = " & (endTimer…

可視列に対して連番

Sub 可視列連番()'可視列に対して連番 Dim r1, r2 As Range Dim i As Long Set r2 = ActiveSheet.UsedRange.Columns(1) Set r2 = r2.SpecialCells(xlCellTypeVisible) i = 0 For Each r1 In r2.Cells r1.Value = i i = i + 1 Next End Sub

パスクエリ サンプル

Sub ExecutePassThroughQuery() ’Microsoft ActiveX Data Objects x.x Library Dim conn As ADODB.Connection Dim cmd As ADODB.Command Dim rs As ADODB.Recordset Dim connectionString As String Dim sqlQuery As String ' SQL Serverへの接続情報 connectionString = "Provider=SQLOLEDB;Data Source=your_server_name;Initia…

自作関数.xlam IndexMatchとxlookup

’開発タブ￥Excelアドインから取り込み Function IndexMatch(検索値 As Variant, 検索範囲 As Range, 戻り範囲 As Range) Set IndexMatch = WorksheetFunction.Index(戻り範囲, WorksheetFunction.Match(検索値, 検索範囲, 0)) End FunctionFunction XLOOKUP(検索値, 検索列範囲, 戻り列範囲, 見つからない場合) As VariantDim i As Long, j As Long, master, data XLOOKUP = 見つからない場合m…

Excelからアクセスデータ抽出時、パラメータをエクセルセル値から読み取りさせる

Option Explicit Sub ExcelからAccessデータ抽出パラメータ条件付き()'Microsoft ActiveX Data Objects 2.X LibraryとMIcrosoft ADO Ext.x.x for DDL and SecurityをVBEツールから参照設定 Dim cnn As ADODB.Connection Dim rst As ADODB.Recordset Dim cmd As ADODB.Command Dim dbPath As String dbPath = "D:\ThinkpadMark3\自学\filename変更_bat類\.xls…

マトリクス表をデータリストに置き換える

Sub マトリクス表をデータリストに置き換える() Dim wsInput As Worksheet Dim wsOutput As Worksheet Dim inputRange As Range Dim outputRange As Range Dim i As Long, j As Long, k As Long ' マトリクス表があるシートと範囲を指定 Set wsInput = ThisWorkbook.Sheets("Sheet3") Set inputRange = wsInput.UsedRange ' 出力先のシートとセルを指定 Set wsOutput = ThisWor…

A列項目の種類別に、B列項目を取りまとめる

Sub A列項目の種類別に、B列項目を取りまとめる() Dim wsSource As Worksheet Dim wsDestination As Worksheet Dim lastRow As Long Dim uniqueValues As Collection Dim cell As Range Dim key As Variant Dim result As String ' ソースシートと宛先シートを指定 Set wsSource = ThisWorkbook.Sheets("Sheet1") ' ソースシートの名前を適切に変更 Set wsDestination = ThisW…

各シートに新しい列を挿入して最終行までシート名を記載

Sub 各シートに新しい列を挿入して最終行までシート名を記載() Dim ws As Worksheet Dim lastRow As Long Dim newCol As Integer ' 各シートに対してループ For Each ws In Worksheets ' シートの最終行を取得 lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row ' 新しい列を挿入 newCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1 ws.Columns(newCol).Insert…

各シートにシート名をA1セルに記載

Sub 各シートにシート名をA1セルに記載() Dim ws As Worksheet ' 各シートに対してループ For Each ws In Worksheets ' 各シートのA1セルにシート名を記載 ws.Range("A1").Value = ws.Name Next wsEnd Sub

アクティブブックのシートをまとめる

Sub アクティブブックのシートをまとめる() Dim ws As Worksheet Dim summarySheet As Worksheet Dim lastRowSummary As Long, lastRowSource As Long Dim lastCol As Long Dim sourceRange As Range, destinationRange As Range ' 新しいシートを作成 Set summarySheet = Sheets.Add(After:=Sheets(Sheets.Count)) summarySheet.Name = "まとめ" ' シートの数…

フォルダ内ファイル名に作成日を付け加える・作成日がついている場合は更新日に変更

On Error Resume Next Set objFSO = CreateObject("Scripting.FileSystemObject") ' スクリプトのフルパスを取得scriptPath = WScript.ScriptFullName ' スクリプトが存在するディレクトリを取得scriptFolder = objFSO.GetParentFolderName(scriptPath) ' フォルダ内のすべてのファイルに対して処理ProcessFilesInFolder scriptFolder ' エラーチェックIf Err.Number <> 0 Then WScript.…

バッチでExcelマクロを呼び出し起動

@echo offset ExcelPath="C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE" REM Excelのインストールパスset ExcelFile="C:\パス\MyExcelFile.xlsm" REM Excelファイルのパスset VBAMacro="MyMacro" REM 実行したいVBAマクロの名前 start "" %ExcelPath% /e %ExcelFile% CALL :RunMacroexit :RunMacroping 127.0.0.1 -n 2 > nul REM Excelが起動…

vbsでExcelマクロ呼び出し起動

Set objExcel = CreateObject("Excel.Application")objExcel.Visible = False ' Excelウィンドウを非表示にする ' ExcelファイルのパスstrExcelPath = "C:\パス\MyExcelFile.xlsm" ' Excelファイルを開くSet objWorkbook = objExcel.Workbooks.Open(strExcelPath) ' VBAマクロを実行objExcel.Run "MyMacro" ' Excelを閉じるobjWorkbook.Close SaveChanges:=Falseob…

バッチファイル呼び出し vbs

Set objShell = CreateObject("WScript.Shell")objShell.Run "Z:\Work\立ち上げたいバッチ.bat", 1, True

シート内で、比較と記載

Sub 比較と記載() Dim ws As Worksheet Dim lastRow1, lastRow2 As Long Dim aRange As Range, cRange As Range Dim aValue As Variant, cValue As Variant Dim bColumn As Range, dColumn As Range Dim i As Long ' 対象のシートを設定 Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を変更する必要があるかもしれません ' 最終行を取得 lastRow1 = ws.Cells(ws…

VBSにて、ファイル名の名前を一部削除して、指定フォルダへ移動

Set objFSO = CreateObject("Scripting.FileSystemObject") ' ソースフォルダのパスを指定sourceFolder = "C:\パス\から\あなたの\ソース\フォルダ"'スクリプトが配置されているフォルダをソースフォルダとして指定'scriptFolder = Replace(WScript.ScriptFullName, WScript.ScriptName, "") sourceFolder = scriptFolder ' 宛先フォルダのパスを指定destinationFolder = "C:\パス\から\あなたの\宛先\フォルダ" '…

vbsにて、対象ファイルに名前追加して、指定ホルダへ移動

Set objFSO = CreateObject("Scripting.FileSystemObject") ' ソースフォルダのパスを指定sourceFolder = "C:\パス\から\あなたの\ソース\フォルダ"'スクリプトが配置されているフォルダをソースフォルダとして指定'scriptFolder = Replace(WScript.ScriptFullName, WScript.ScriptName, "") sourceFolder = scriptFolder ' 宛先フォルダのパスを指定destinationFolder = "C:\パス\から\あなたの\宛先\フォルダ" '…

vbe→vbs

Option Explicit Const BIF_NEWDIALOGSTYLE = &H40Const BIF_NONEWFOLDERBUTTON = &H200Const BIF_RETURNONLYFSDIRS = &H1 Const FOR_READING = 1Const FOR_WRITING = 2 Const TAG_BEGIN1 = "#@~^" Const TAG_BEGIN2 = "==" Const TAG_BEGIN2_OFFSET = 10 Const TAG_BEGIN_LEN = 12Const TAG_END = "==^#~@" Const TAG_END_…