由不同的用户运行不同的宏或代码部分

时间：2015-09-30 13:22:29

标签： excel vba

我写了一个宏来将文件保存到特定的URL上。 问题是该宏由我公司中的不同用户运行，具有访问Intranet文件夹的不同级别的权限。 宏由电子表格上的按钮激活。 据我所知，我至少有两种解决方案：

  1. 创建不同的宏并将它们链接到不同的按钮（用户将按其各自的按钮。不优雅 - 可能会出错）
  2. 让VBA识别用户并使用正确的SAVE AS网址运行特定的宏或代码字符串。 我会避免第一个解决方案，但我不知道如何编写第二个解决方案。

    3. 以下是 SAVE AS 方法中包含路径的整个代码：

    Sub test_salva()

Workbooks.Open Filename:= _
    "\\Share\Qualita_MG\Gestione Documentazione\Doc. TECNICI-  QUALITA'\Moduli di supporto\C - Controllo Qualita'\MOD UNICO.xlsm"
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveSheet.Range("A3").Select
  Do While Not IsEmpty(ActiveCell)
  ActiveCell.Offset(1, 0).Select
  Loop
  ActiveCell.Offset(-1, 0).Select

Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AF31").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("R2").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("B5").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AD4").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AD5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
progressivo = Range("AF31")
nomefile = Range("B5")
ActiveWorkbook.SaveAs Filename:= _"\\Share\Qualita_MG\Documentazione  registrazione\Certificati SERIE\2015\S - Certificati Tubi\" & progressivo & "-" & nomefile _ 
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 
     Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveSheet.Range("A3").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
variabile = Selection
nome = ActiveCell.Range("c1")
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    "S%20-%20Certificati%20Tubi\" & variabile & "-" & nome & ".xlsm",   TextToDisplay:=nome

ActiveCell.Offset(1, -2).Range("A1").Select

End Sub

1 个答案:

答案 0 :(得分：0)

我想将解决方案发布到我的问题：

Sub test_salva()

**If Application.UserName = "Manuela Frignani" Then GoTo line1 Else GoTo         line2**

**line1:**
Workbooks.Open Filename:= _
    "Z:\Certificati SERIE\2015\MOD UNICO.xlsm"
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveSheet.Range("A3").Select
  Do While Not IsEmpty(ActiveCell)
  ActiveCell.Offset(1, 0).Select
  Loop
  ActiveCell.Offset(-1, 0).Select

Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AF31").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("R2").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("B5").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AD4").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AD5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
progressivo = Range("AF31")
nomefile = Range("B5")
ActiveWorkbook.SaveAs Filename:= _
    "Z:\Certificati SERIE\2015\S - Certificati Tubi\" & progressivo & "-" &  nomefile _
    , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 
     Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveSheet.Range("A3").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
variabile = Selection
nome = ActiveCell.Range("c1")
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    "S%20-%20Certificati%20Tubi\" & variabile & "-" & nome & ".xlsm",    TextToDisplay:=nome
With Selection.Font
    .Name = "Calibri Light"
    .Size = 17.6
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleSingle
    .ThemeColor = xlThemeColorHyperlink
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Selection.Font.Size = 16
Selection.Font.Size = 14
Selection.Font.Size = 12
Selection.Font.Size = 11
Selection.Font.Size = 10
Selection.Font.Underline = xlUnderlineStyleNone
Selection.Font.Underline = xlUnderlineStyleSingle
With Selection.Font
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0.499984740745262
End With
ActiveCell.Offset(1, -2).Range("A1").Select
GoTo line3


**line2:**
Workbooks.Open Filename:= _
    "\\Share\Qualita_MG\Gestione Documentazione\Doc. TECNICI- QUALITA'\Moduli di supporto\C - Controllo Qualita'\MOD UNICO.xlsm"
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveSheet.Range("A3").Select
  Do While Not IsEmpty(ActiveCell)
  ActiveCell.Offset(1, 0).Select
  Loop
  ActiveCell.Offset(-1, 0).Select

Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AF31").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks  _
    :=False, Transpose:=False

Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("R2").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("B5").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AD4").Select
ActiveSheet.Paste
Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("MOD UNICO.xlsm").Activate
Sheets("Ita-Eng").Activate
Range("AD5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
progressivo = Range("AF31")
nomefile = Range("B5")
ActiveWorkbook.SaveAs Filename:= _
    "\\Share\Qualita_MG\Documentazione registrazione\Certificati SERIE\2015\S - Certificati Tubi\" & progressivo & "-" & nomefile _
    , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 
     Windows("RIEPILOGATIVO 2015.xlsb.xlsm").Activate
ActiveSheet.Range("A3").Select
Do While Not IsEmpty(ActiveCell)
  ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
variabile = Selection
nome = ActiveCell.Range("c1")
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    "S%20-%20Certificati%20Tubi\" & variabile & "-" & nome & ".xlsm",  TextToDisplay:=nome
With Selection.Font
    .Name = "Calibri Light"
    .Size = 17.6
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleSingle
    .ThemeColor = xlThemeColorHyperlink
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
 End With
    Selection.Font.Size = 16
    Selection.Font.Size = 14
    Selection.Font.Size = 12
    Selection.Font.Size = 11
    Selection.Font.Size = 10
    Selection.Font.Underline = xlUnderlineStyleNone
    Selection.Font.Underline = xlUnderlineStyleSingle
With Selection.Font
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0.499984740745262
End With
    ActiveCell.Offset(1, -2).Range("A1").Select

**line3:**

End Sub
相关问题
最新问题