Question

大家好我需要有选择地将整个行从sheet1复制到其他工作表。截至目前，我使用复选框选择行，然后将选定的行复制到用户选择的工作表。但我面临一个奇怪的错误。有时代码运行正常，将精确数据复制到工作表，但一段时间后它会从无处复制错误的值。你能帮我解决这个问题吗？粘贴我正在使用的代码。

Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double

Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

For cell = 2 To LRow
    If Cells(cell, "A").Value <> "" Then
        MyLeft = Cells(cell, "E").Left
        MyTop = Cells(cell, "E").Top
        MyHeight = Cells(cell, "E").Height
        MyWidth = Cells(cell, "E").Width
        ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
        With Selection
            .Caption = ""
            .Value = xlOff
            .Display3DShading = False
        End With
    End If
Next cell

Application.ScreenUpdating = True
End Sub


Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
    chkbx.Delete
Next
End Sub


Sub CopyRows()
Dim Val As String
Val = InputBox(Prompt:="Sheet name please.", _
          Title:="ENTER SHEET NAME", Default:="Sheet Name here")
For Each chkbx In ActiveSheet.CheckBoxes
    If chkbx.Value = 1 Then
        For r = 1 To Rows.Count
            If Cells(r, 1).Top = chkbx.Top Then
                With Worksheets(Val)
                    LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    .Range("A" & LRow & ":AF" & LRow) = _
                    Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
                End With
                Exit For
            End If
        Next r
    End If
Next
End Sub

正常复制输出： enter image description here

相同值的错误复制输出： enter image description here

Answer 1

对正常输出和错误输出进行快速比较，看起来您的某些单元格/列在目标工作表中没有正确格式化（您正在“粘贴”这些值）。

例如，普通副本（值582.16）中的“基本更改”列格式为“常规”或“数字”。目标表中的同一列被格式化为日期（在Excel中转换为日期值的582.16将为8/4/1901，或8/4/01，如屏幕所示。

只需确保列格式化以显示您期望的数据类型。在目标工作表上，选择列，右键单击“设置单元格格式”，然后选择适当的数据类型。

<强> --- --- EDIT

要自动化格式化，您必须复制并粘贴值，包括格式。您的代码将改变：

With Worksheets(Val)
    LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
    .Range("A" & LRow & ":AF" & LRow) = _
    Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
End With

要

With Worksheets(Val)
    LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
    Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Copy
    .Range("A" & LRow).PasteSpecial (xlPasteValuesAndNumberFormats)
End With

Answer 2

我已添加了LinkedCell属性的复选框。这有助于在选中复选框时识别行。我还添加了一个函数check_worksheet_exists，它将检查工作簿是否存在。

Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double

Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).row

For cell = 2 To LRow
    If Cells(cell, "A").Value <> "" Then
        MyLeft = Cells(cell, "E").Left
        MyTop = Cells(cell, "E").Top
        MyHeight = Cells(cell, "E").Height
        MyWidth = Cells(cell, "E").Width
        ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
        With Selection
            .Caption = ""
            .Value = xlOff
            .Display3DShading = False
            .LinkedCell = Cells(cell, "AZ").Address
        End With
    End If
Next cell

Application.ScreenUpdating = True
End Sub


Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
    chkbx.Delete
Next
End Sub


Sub CopyRows()

    Dim Val As String
    Dim row As Long

    Val = InputBox(Prompt:="Sheet name please.", Title:="ENTER SHEET NAME", Default:="Sheet Name here")

    If check_worksheet_exists(ThisWorkbook, Val, False) = False Then
        Exit Sub
    End If

    For Each chkbx In ActiveSheet.CheckBoxes
        If chkbx.Value = 1 Then
            row = Range(chkbx.LinkedCell).row

            With Worksheets(Val)
                LRow = .Range("A" & Rows.Count).End(xlUp).row + 1
                .Range("A" & LRow & ":AF" & LRow) = ActiveSheet.Range("A" & row & ":AF" & row).Value
            End With

        End If
    Next
End Sub




Function check_worksheet_exists(tBook As Workbook, ByVal check_sheet As String, Optional no_warning As Boolean = False) As Boolean

    On Error Resume Next
    Dim wkSht As Worksheet
    Set wkSht = tBook.Sheets(check_sheet)

    If Not wkSht Is Nothing Then
        check_worksheet_exists = True
    ElseIf wkSht Is Nothing And no_warning = False Then
        MsgBox "'" & check_sheet & "' sheet does not exist", vbCritical, "Error"
    End If

    On Error GoTo 0

End Function

Answer 3

我不能立即看到你引用的错误，除非你指的是散列符号序列###？这些只是表明列不够宽。

Worksheets(Val).Range("A1").CurrentRegion.EntireColumn.AutoFit

BTW我不认为Val是一个明智的变量名;）

将Sheet1中的选择性行复制到Sheet2

3 个答案: