1

大家好，我需要有选择地将整个行从 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

正常复印输出： 在此处输入图像描述

相同值的错误复制输出： 在此处输入图像描述

4

3 回答 3

1

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

例如，普通副本中的 Base Change 列（值 582.16）被格式化为 General 或 Number。目标工作表中的同一列被格式化为日期（在 Excel 中转换为日期值的 582.16 将是 8/4/1901 或 8/4/01，如屏幕所示。

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

- -编辑 - -

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

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
于 2013-07-16T16:35:29.617 回答
1

我添加了带有 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
于 2013-07-16T16:49:34.423 回答
0

我无法立即看到您所指的错误，除非您指的是哈希符号序列###？这些只是表明列不够宽。

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

顺便说一句，我不认为 Val 是一个明智的变量名；）

于 2013-07-16T16:34:54.980 回答