Question

我正在尝试编写一个宏，它将要求用户提供工作簿，宏打开工作簿。用户选择复制范围并指定在Userform中粘贴数据的工作表。宏复制选择Range到指定的工作表。

但是我遇到了一些问题。

这是代码：

Public Sub copy_WB()
Application.DisplayAlerts = False
Dim wbk As Workbook, answer As String,lrow as long, lcol as long
Dim UserRange As Range

Prompt = "Select a cell for the output."
Title = "Select a cell"

answer = MsgBox("Would you like to clear all data?", vbYesNo, "Confirmation")
If answer = vbYes Then
    Call clear_all
End If

Set wbk = Get_workbook
If wbk Is Nothing Then
Exit Sub
End If
'   Display the Input Box
    On Error Resume Next
    Set UserRange = Application.InputBox( _
        Prompt:=Prompt, _
        Title:=Title, _
        Type:=8) 'Range selection

'   Was the Input Box canceled?
    If UserRange Is Nothing Then
        MsgBox "Canceled."
        Exit Sub
    Else
        UserRange.Parent.Parent.Activate
        UserRange.Parent.Activate
        lrow = UserRange(UserRange.Count).Row
        lcol = UserRange(UserRange.Count).Columns

        If lrow > 1000000 Or lcol > 15000 Then
        ActiveSheet.UsedRange.Copy
        Else
        UserRange.Copy
        End If

        sh_sel.Show
        Do While IsUserFormLoaded("sh_sel")
            DoEvents
        Loop

        ActiveSheet.Range("A2").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If

ThisWorkbook.Worksheets(3).Range("A1") = lrow
ThisWorkbook.Worksheets(3).Range("A2") = lcol
wbk.Close False
Application.DisplayAlerts = True
End Sub


Private Sub clear_all()
Dim wb As Workbook, shs As Worksheet, lrow As Single, lcol As Single
Set wb = ThisWorkbook

For Each shs In wb.Worksheets

    With shs.UsedRange
        lrow = .Rows(.Rows.Count).Row
        lcol = .Columns(.Columns.Count).Column
    End With
        If Not (lrow = 0 Or lrow = 1) Then
    With shs
        .Range(.Cells(2, 1), .Cells(lrow, lcol)).clear
    End With
        End If
Next shs

End Sub

Function Get_workbook() As Workbook
    Dim wbk As Workbook, pathb As String
    pathb = ThisWorkbook.path
    ChDir pathb


    wbk_name = Application.GetOpenFilename(Title:="Please choose File:", FileFilter:="Excel Files *.xls*(*.xls*),")
        On Error Resume Next
        If Len(Dir(wbk_name)) = 0 Then
        MsgBox "The file was not chosen - macro off."
        Exit Function
        Else
        Set wbk = Workbooks.Open(wbk_name)
        End If
        Set Get_workbook = wbk

End Function

Function IsUserFormLoaded(ByVal UFName As String) As Boolean
    Dim UForm As Object

    IsUserFormLoaded = False
    For Each UForm In VBA.UserForms
        If UForm.Name = UFName Then
            IsUserFormLoaded = True
            Exit For
        End If
    Next
End Function 'IsUserFormLoaded

我面临的第一个问题是用户按下时位于工作表左上角的按钮用于选择整个工作表范围，不会被复制。我试图通过添加所选范围的最后一行的条件以某种方式更正它...（请参阅代码）。

但实际上并没有效果。有时它复制范围，有时没有。

第二个问题：输入框在宏运行时消失。不知道为什么它会开心。

用户形式代码：

Private Sub UserForm_Initialize()
    Dim sh As Worksheet

    For Each sh In ThisWorkbook.Sheets
        ListBox1.AddItem sh.Name
    Next sh

Me.StartUpPosition = 0
  Me.Left = Application.Left + (0.5 * Application.Width) - (0.5 * Me.Width)
  Me.Top = Application.Top + (0.5 * Application.Height) - (0.5 * Me.Height)
    HideTitleBar.HideTitleBar Me
End Sub


Private Sub ListBox1_Click()
    ThisWorkbook.Sheets(ListBox1.Value).Activate
    Unload Me
End Sub

用户表单包含当前工作簿中的工作表列表，用户选择工作表数据后将被粘贴。

复印最大范围的问题。用户选择的范围

0 个答案: