Question

我编写了将数据分类为列/行的代码。

我有一张最终的工作表，可以复制和粘贴这些数据。完成此操作后，将显示userform以供用户输入。

当我的宏打开新工作簿时，它只显示用户窗体。虽然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

如何显示/显示工作簿？

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

打开工作簿然后显示/显示

1 个答案: