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 A…

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") ' すでに同じ名前のシート…

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

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" ' データをレコードセット…

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…

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 = …

Private Sub ExcelExport() '変数宣言Dim filePath As String 'Excelエクスポート先のファイルパス ’filePath = "D:\保存先\" & "Export_" & Format(Date, "yymmdd") & ".xlsx" ' Excelファイルを保存するデスクトップのパスを取得 filePath = Environ("USER…

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…

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データベー…

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 …

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…

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 ' デー…

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 …

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

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(orig…

Sub フォルダ内の全シート1を取りまとめる() Dim フォルダパス As String Dim 対象ファイル As String Dim 対象ブック As Workbook Dim 一時ブック As Workbook Dim シート As Worksheet Dim 合成シート As Worksheet Dim 最終行 As Long Application.Screen…

Option Explicit Sub フォルダ内の全集計ファイルを取りまとめる() Dim フォルダパス As String Dim 対象ファイル As String Dim 対象ブック As Workbook Dim 一時ブック As Workbook Dim シート As Worksheet Dim 合成シート As Worksheet Dim 最終行 As Lo…

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("セ…

Function rightcellvalue(rng As Range) As Variant Dim lastCell As Range Dim ws As Worksheet ' シートをアクティブにする（指定範囲がどのシートにあるかを確認） Set ws = rng.Worksheet ws.Activate ' 指定範囲内の最後のセルを取得 Set lastCell = rn…

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 ' ピボットテーブルがあるシート…

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 = Thi…

Sub ResetComments() Dim cmt As Comment 'すべてのコメントをループして削除する For Each cmt In ActiveSheet.Comments cmt.Delete Next cmtEnd 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…

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

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.…

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

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 = Workshee…

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 referenc…

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