Открыть книгу с помощью макроса, показать/отобразить открытую книгу

Question

Я написал немного кода для сортировки некоторых данных в конкретных столбцах/строках. Затем у меня есть окончательный лист, на котором эти данные копируются и вставляются. Когда это действие будет завершено, я хочу, чтобы пользовательская форма отображалась для ввода пользователем. Однако проблема заключается в том, что когда мой макрос открывает новую книгу, он отображает только пользовательскую форму, и рабочая книга недоступна для просмотра, хотя excel говорит, что она открыта. Код, который я до сих пор:

Sub Measurement_Info() 
 
Dim iL As Long, rng1 As Range, sizex As Long, sizexs As Long, i As Long, Commentrng As Range, Commentpaste As Range, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, x As Workbook, y As Workbook, rng2 As Range, pasterng As Range, lRow As Long, lRows As Long, var As Range, var1 As Range, var2 As Range, var3 As Range, var4 As Range, var5 As Range, var6 As Range, var7 As Range, var8 As Range, var9 As Range, titlerow As Long 
 
Dim Title1 As Range, Title2 As Range, titlerows As Long, comments As Range, MSG1 As Integer, app As New Excel.Application, stitle As String, objExcel 
 

 
Set x = Workbooks.Open("C:\VBA Macros\Measurement Database Tool\INCALog\LogFileComments.csv") 
 

 
Set ws1 = Workbooks("LogFileComments").Worksheets("LogFileComments") 
 
Set ws2 = Workbooks("Measurement Database SPA").Worksheets("Measurement Info Sheet") 
 
Set ws3 = Workbooks("Measurement Database SPA").Worksheets("Measurement Signal List - SPA") 
 

 
'Text to columns, seperate into columns 
 
ws1.Columns(2).TextToColumns , _ 
 
Destination:=ws1.Range("B1"), _ 
 
DataType:=xlDelimited, _ 
 
TextQualifier:=xlDoubleQuote, _ 
 
ConsecutiveDelimiter:=True, _ 
 
Other:=True, _ 
 
OtherChar:="|", _ 
 
TrailingMinusNumbers:=False 
 

 
iL = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row 
 
For i = 1 To iL 
 
Set Title1 = ws1.Cells(i, 1) 
 

 
titlerow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row 
 
titlerows = titlerow + 1 
 
Set Title2 = ws2.Cells(titlerows, 1) 
 
Title2.Value = Title1.Value 
 
Set rng1 = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, ws1.Columns.Count).End(xlToLeft).Columns) 
 
Set var = rng1.Find("Date: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 2) 
 
pasterng.Value = var.Value 
 
End If 
 

 
Set var1 = rng1.Find("Time: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var1 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 3).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 3) 
 
pasterng.Value = var1.Value 
 
End If 
 

 
Set var2 = rng1.Find("Recording Duration: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var2 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 4).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 4) 
 
pasterng.Value = var2.Value 
 
End If 
 

 
Set var3 = rng1.Find("Database: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var3 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 5).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 5) 
 
pasterng.Value = var3.Value 
 
End If 
 

 
Set var4 = rng1.Find("Experiment: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var4 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 6).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 6) 
 
pasterng.Value = var4.Value 
 
End If 
 

 
Set var5 = rng1.Find("Workspace: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var5 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 7).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 7) 
 
pasterng.Value = var5.Value 
 
End If 
 

 
Set var6 = rng1.Find("Devices: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var6 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 8).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 8) 
 
pasterng.Value = var6.Value 
 
End If 
 

 
Set var7 = rng1.Find("Program Description: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var7 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 9).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 9) 
 
pasterng.Value = var7.Value 
 
End If 
 

 
Set var8 = rng1.Find("WP: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var8 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 10).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 10) 
 
pasterng.Value = var8.Value 
 
End If 
 

 
Set var9 = rng1.Find("RP: ", LookIn:=xlValues, LookAt:=xlPart) 
 
If Not var9 Is Nothing Then 
 
lRow = ws2.Cells(ws2.Rows.Count, 11).End(xlUp).Row 
 
lRows = lRow + 1 
 
Set pasterng = ws2.Cells(lRows, 11) 
 
pasterng.Value = var9.Value 
 
End If 
 

 
Set comments = var9.Offset(0, 1) 
 
Set Commentrng = ws1.Range(comments, ws1.Cells(i, ws1.Columns.Count).End(xlToLeft)) 
 
sizex = Commentrng.Columns.Count 
 
sizexs = sizex + 11 
 
Set Commentpaste = ws2.Range(ws2.Cells(titlerows, 12), ws2.Cells(titlerows, sizexs)) 
 
Commentpaste.Value = Commentrng.Value 
 

 
Next i 
 
    
 
'Close x: 
 
Application.DisplayAlerts = False 
 
x.Close 
 
Application.DisplayAlerts = True 
 
      
 
'close & save Final sheet 
 
Application.DisplayAlerts = False 
 
Workbooks("Measurement Database SPA").Save 
 
Workbooks("Measurement Database SPA").Close 
 
Application.DisplayAlerts = True 
 

 

 
MSG1 = MsgBox("Would you like to add comments", vbYesNo, "Add comments") 
 
If MSG1 = vbYes Then 
 
Set y = Workbooks.Open("C:\VBA Macros\Measurement Database Tool\Measurement Database SPA.xlsm") 
 
Set objExcel = CreateObject("WScript.Shell") 
 
objExcel.AppActivate "Microsoft Excel" 
 
Set objExcel = Nothing 
 
MsgBox "Please select filename in column 1" 
 
Application.Run ("'Measurement Database SPA.xlsm'!Additional_Comments") 
 

 
Application.DisplayAlerts = False 
 
Workbooks("Parse_Compare_Import").Save 
 
Application.DisplayAlerts = True 
 
End If 
 
End Sub​

Does anybody know how to display show open workbooks when opened via a macro? 

Answer 1

Я считаю, что это должен делать то, что вы хотите:

Option Explicit 

' Needs to be at the top of the module 
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long 

(...) 

Sub test() 
    Application.ScreenUpdating = True 
    MSG1 = MsgBox("Would you like to add comments", vbYesNo, "Add comments") 
    If MSG1 = vbYes Then 

    Set y = Workbooks.Open("C:\Users\Mohamed samatar.DSSE-EMEA\Documents\VBA Macros" _ 
      & "\Measurement Database Tool\Measurement Database SPA.xlsm") 

    MsgBox "Please select filename in column 1" 
    Application.Run ("'Measurement Database SPA.xlsm'!Additional_Comments") 
    Workbooks("Measurement Database SPA").Activate 
    SetForegroundWindow ActiveWorkbook.Application.hWnd 
    (...) 
End Sub