Макрос vba с 3 кнопками, связанными между собой - PullRequest
Новая
       55

Макрос vba с 3 кнопками, связанными между собой

0 голосов
/ 23 января 2020

Как применить функцию макроса с тремя командными кнопками? Я пытался с приведенным ниже кодом .. но возвращает макрос, примененный на другом листе.

cmd button1: просматривает основной файл необработанных данных.

cmd button2: файл данных vlookup для основного файла необработанных данных.

cmd button3: Запустите функцию ниже макроса основной файл необработанных данных.

ваши идеи будут очень полезны .. заранее спасибо. 

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$1:$BE$8837").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

1 Ответ

0 голосов
/ 23 января 2020

Когда у вас есть путь к файлу, используя метод 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>")
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...