將選擇行從Sheet1複製到Sheet2

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 

普通複印輸出：

錯誤複印輸出，用於相同的價值觀：

Answer 1

做正常的和錯誤輸出的比較快，它看起來像你的一些細胞/列的格式不正確在您的目的地工作表（您正在「粘貼」這些值的位置）。

例如，普通副本中的基本更改列（值爲582.16）被格式化爲常規或編號。在目標表的同一列的格式爲轉換爲Excel中的日期值的日期（582.16將是1901年8月4日，或01年8月4日，如在你的屏幕。

只需確保列格式化爲顯示您所期望的數據類型。您的目的地表，選擇列中，右鍵單擊「單元格格式」，然後選擇適當的數據類型。

---編輯---

要自動執行格式設置，您必須複製並粘貼包含這些格式的值。您的代碼將從此更改：

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 

TO

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

我不能馬上看到你提到的，除非你是指散列的序列中的錯誤標誌###？這些僅表明列不夠寬。

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

BTW，我不認爲瓦爾是一個明智的變量名;）

Answer 3

我添加了一個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