vba 带有 3 个相互链接的命令按钮的宏
vba macro with 3 command buttons linked with each other
如何使用三个命令按钮应用宏功能？我尝试使用以下代码......但是 returns 宏应用于不同的 sheet。
cmd button1: 浏览主原始数据文件。
cmd 按钮 2：主要原始数据文件的 vlookup 数据文件。
cmd 按钮 3：运行 下面的宏对主要原始数据文件起作用。
你的想法会很有帮助..提前致谢。
Option Explicit
Sub currentZOE3()
'declare variable to store path
Dim Get_Path As String
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show <> 0 Then
Get_Path = .SelectedItems(1)
End If
Worksheets("sheet1").Cells(3, 4).Value = Get_Path
End With
End Sub
Sub lastweekZOE3()
'declare variable to store path
Dim Get_Path As String
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show <> 0 Then
Get_Path = .SelectedItems(1)
End If
Worksheets("sheet1").Cells(5, 4).Value = Get_Path
End With
End Sub
Sub Macro4()
'
' Macro4 Macro
'
'
Dim updWb As Workbook
Dim DSheet As Worksheet
Set updWb = Workbooks.Open(Worksheets("sheet1").Cells(3, 4).Value)
Set DSheet = updWb.Sheets("Sheet1")
Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
Columns("N:N").Select
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
Columns("Q:S").Select
Selection.Insert Shift:=xlToRight
Range("Q1") = "Concantenate"
Range("R1") = "Delivery Plan"
Range("S1") = "Last Week Comments"
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=RC[-16]&RC[-9]&RC[-7]"
Range("S2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],'[Last Week.xlsx]Sheet1'!C1:C2,2,0)"
Range("R2").Select
ActiveCell.FormulaR1C1 = _
"=IFS(RC22=""YBWR"",""What"",ISNUMBER(RC25),""Fully Delivered"",RC19=""Billable Only"",""BILLABLE ONLY"",AND(ISBLANK(RC25),NOT(ISBLANK(RC27))),""Under shipment"",AND(ISBLANK(RC25),ISBLANK(RC27),ISNUMBER(RC14)),""Under packing"",AND(ISBLANK(RC25),ISBLANK(RC27),ISBLANK(RC14)),TEXT(WEEKNUM(RC23),""W00""))"
Range("P3").Select
Selection.End(xlDown).Select
Range("Q8833:S8833").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Cells.Select
Range("Q8833").Activate
Selection.Columns.AutoFit
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""What"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 12173758
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""Fully Delivered"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 5691552
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""under shipment"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 3774674
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""under packing"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 15793920
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
Sheets(Array("Sheet2", "Sheet3")).Select
Sheets("Sheet3").Activate
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Range("A1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A1:A8837"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A:$BE37").AutoFilter Field:=1
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long
Dim pvtfield As PivotField
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("Sheet1")
'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)
'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="PivotTable")
'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="PivotTable")
'Insert Row Fields
With ActiveSheet.PivotTables("PivotTable").PivotFields("Sold to name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable").PivotFields("Sales Document")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTable").PivotFields("Customer purchase order number")
.Orientation = xlRowField
.Position = 3
End With
'Insert Column Fields
With ActiveSheet.PivotTables("PivotTable").PivotFields("Delivery Plan")
.Orientation = xlColumnField
.Position = 1
End With
'Insert Data Field
With ActiveSheet.PivotTables("PivotTable").PivotFields("SO Net value")
.Orientation = xlDataField
.Position = 1
.Function = xlSum
.NumberFormat = "#,##0"
.Name = " Sum SO Net value "
End With
'classic and expand/collapse button removal
Range("C7").Select
With ActiveSheet.PivotTables("PivotTable")
.InGridDropZones = True
.RowAxisLayout xlTabularRow
End With
Range("B4").Select
ActiveSheet.PivotTables("PivotTable").ShowDrillIndicators = False
'Format Pivot
TableActiveSheet.PivotTables("PivotTable").ShowTableStyleRowStripes = TrueActiveSheet.PivotTables("PivotTable").TableStyle2 = "PivotStyleMedium9"
End Sub
使用 FileDialog 方法获得文件路径后。
您可以使用以下函数打开 excel 并更新其工作表的内容。
Dim updWb As Workbook, wSheet As Worksheet
Set updWb = Workbooks.Open("<path of the workbook to be updated>")
Set wSheet = updWb.Sheets("<sheet-name> or <sheet-index>")
如何使用三个命令按钮应用宏功能？我尝试使用以下代码......但是 returns 宏应用于不同的 sheet。
cmd button1: 浏览主原始数据文件。
cmd 按钮 2：主要原始数据文件的 vlookup 数据文件。
cmd 按钮 3：运行 下面的宏对主要原始数据文件起作用。
你的想法会很有帮助..提前致谢。
Option Explicit
Sub currentZOE3()
'declare variable to store path
Dim Get_Path As String
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show <> 0 Then
Get_Path = .SelectedItems(1)
End If
Worksheets("sheet1").Cells(3, 4).Value = Get_Path
End With
End Sub
Sub lastweekZOE3()
'declare variable to store path
Dim Get_Path As String
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show <> 0 Then
Get_Path = .SelectedItems(1)
End If
Worksheets("sheet1").Cells(5, 4).Value = Get_Path
End With
End Sub
Sub Macro4()
'
' Macro4 Macro
'
'
Dim updWb As Workbook
Dim DSheet As Worksheet
Set updWb = Workbooks.Open(Worksheets("sheet1").Cells(3, 4).Value)
Set DSheet = updWb.Sheets("Sheet1")
Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
Columns("N:N").Select
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
Columns("Q:S").Select
Selection.Insert Shift:=xlToRight
Range("Q1") = "Concantenate"
Range("R1") = "Delivery Plan"
Range("S1") = "Last Week Comments"
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=RC[-16]&RC[-9]&RC[-7]"
Range("S2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],'[Last Week.xlsx]Sheet1'!C1:C2,2,0)"
Range("R2").Select
ActiveCell.FormulaR1C1 = _
"=IFS(RC22=""YBWR"",""What"",ISNUMBER(RC25),""Fully Delivered"",RC19=""Billable Only"",""BILLABLE ONLY"",AND(ISBLANK(RC25),NOT(ISBLANK(RC27))),""Under shipment"",AND(ISBLANK(RC25),ISBLANK(RC27),ISNUMBER(RC14)),""Under packing"",AND(ISBLANK(RC25),ISBLANK(RC27),ISBLANK(RC14)),TEXT(WEEKNUM(RC23),""W00""))"
Range("P3").Select
Selection.End(xlDown).Select
Range("Q8833:S8833").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Cells.Select
Range("Q8833").Activate
Selection.Columns.AutoFit
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""What"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 12173758
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""Fully Delivered"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 5691552
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""under shipment"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 3774674
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""under packing"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 15793920
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
Sheets(Array("Sheet2", "Sheet3")).Select
Sheets("Sheet3").Activate
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Range("A1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A1:A8837"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A:$BE37").AutoFilter Field:=1
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long
Dim pvtfield As PivotField
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("Sheet1")
'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)
'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="PivotTable")
'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="PivotTable")
'Insert Row Fields
With ActiveSheet.PivotTables("PivotTable").PivotFields("Sold to name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable").PivotFields("Sales Document")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTable").PivotFields("Customer purchase order number")
.Orientation = xlRowField
.Position = 3
End With
'Insert Column Fields
With ActiveSheet.PivotTables("PivotTable").PivotFields("Delivery Plan")
.Orientation = xlColumnField
.Position = 1
End With
'Insert Data Field
With ActiveSheet.PivotTables("PivotTable").PivotFields("SO Net value")
.Orientation = xlDataField
.Position = 1
.Function = xlSum
.NumberFormat = "#,##0"
.Name = " Sum SO Net value "
End With
'classic and expand/collapse button removal
Range("C7").Select
With ActiveSheet.PivotTables("PivotTable")
.InGridDropZones = True
.RowAxisLayout xlTabularRow
End With
Range("B4").Select
ActiveSheet.PivotTables("PivotTable").ShowDrillIndicators = False
'Format Pivot
TableActiveSheet.PivotTables("PivotTable").ShowTableStyleRowStripes = TrueActiveSheet.PivotTables("PivotTable").TableStyle2 = "PivotStyleMedium9"
End Sub
使用 FileDialog 方法获得文件路径后。
您可以使用以下函数打开 excel 并更新其工作表的内容。
Dim updWb As Workbook, wSheet As Worksheet
Set updWb = Workbooks.Open("<path of the workbook to be updated>")
Set wSheet = updWb.Sheets("<sheet-name> or <sheet-index>")