将select行从Sheet1复制到Sheet2

大家好，我需要有select地从sheet1复制整个行到其他工作表。 截至目前，我正在使用checkbox来select行，然后将选定的行复制到用户的select表。 但是我正面临着一个奇怪的错误。 有一段时间，代码运行良好，将精确的数据复制到表单中，但是经过一段时间后，它从无处复制错误的值。 你能帮我吗？ 粘贴我正在使用的代码。

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 

正常复制输出：

错误的复制输出相同的值：

Answer 1

做一个正常和错误的输出快速比较，它看起来像你的目标工作表（你正在“粘贴”的值）的一些单元格/列没有正确格式。

例如，普通副本中的基本更改列（值为582.16）格式为常规或编号。 目标工作表中的同一列被格式化为date（582.16转换为Excel中的date值将为8/4/1901或8/4/01，如屏幕所示。

只要确保列的格式化，以显示您所期望的数据types。 在目标工作表上，select该列，右键单击“格式化单元格”，然后select适当的数据types。

– -编辑 – –

要自动执行格式化，您必须复制并粘贴这些格式的值。 你的代码会从这个变成：

 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属性的checkbox。 这有助于在checkbox被选中时识别行。 此外，我已经添加了一个函数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 

顺便说一句，我不认为Val是一个明智的variables名称;）