Question

Image of row I'm trying to copy to workbook

我要将以下行复制到另一个excel工作簿中。这是我到目前为止的代码。我不确定如何将行复制到我创建并稍后打开的工作簿中。它复制具有与输入变量值关联的名称的行，但不复制具有值的行，＆＃34; PROGRAM＆＃34;在里面。我不明白为什么。

Sub ProgramExport()

  Dim Program As Range
  Set Program = Range("C1:C2000")
  Dim rng As Range
  Dim wbThis As Workbook
  Dim newBook As Workbook
  Dim value As String
  Dim userID As String
  Dim fn As String
  Dim x As String

  Set newBook = Workbooks.Add

  value = InputBox("Please enter the program you'd like to export.")
  userID = InputBox("Please enter your user id.")
  fn = "C:\Users\" & userID & "\Desktop\" & value & ".xlsx"
  'aFN = "C:\Users\ashaikh5\Desktop\Copy of TS L2L3v11.xlsm"
  newBook.SaveAs (fn)

  x = "PROGRAM"

  For Each cell In Program

      If cell = value Or cell = x Then
          If rng Is Nothing Then
            Set rng = cell.EntireRow
          Else
            Set rng = Union(rng, cell.EntireRow)
          End If
      Else
          'cell.Font.ColorIndex = 3

  End If

  Next
  ActiveWorkbook.Close
  rng.Select
  Selection.Copy
  Workbooks.Open Filename:=fn
  Worksheets("Sheet1").Select
  erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  ActiveSheet.Cells(erow, 1).Select
  ActiveSheet.Paste
  ActiveSheet.Columns("A:L").ColumnWidth = 14
  ActiveSheet.Columns("C").AutoFit
  ActiveSheet.Columns("N:CM").ColumnWidth = 14
  ActiveWorkbook.Save
  ActiveWorkbook.Close
  Application.CutCopyMode = False

End Sub

Answer 1

试试这个：

Sub ProgramExport()

  Dim Program As Range
  Set Program = ThisWorkbook.Worksheets(1).Range("C1:C2000")
  Dim rng As Range
  Dim newBook As Workbook
  Dim value As String
  Dim userID As String
  Dim fn As String
  Dim x As String

  Set newBook = Workbooks.Add

  value = InputBox("Please enter the program you'd like to export.")
  userID = InputBox("Please enter your user id.")
  fn = "C:\Users\" & userID & "\Desktop\" & value & ".xlsx"
  'aFN = "C:\Users\ashaikh5\Desktop\Copy of TS L2L3v11.xlsm"
  newBook.SaveAs (fn)

  x = "PROGRAM"

  For Each cell In Program

      If cell = value Or cell = x Then
          If rng Is Nothing Then
            Set rng = cell.EntireRow
          Else
            Set rng = Union(rng, cell.EntireRow)
          End If
      Else
          'cell.Font.ColorIndex = 3

  End If

  Next
  Dim ws As Worksheet: Set ws = newBook.Worksheets(1)
  erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  rng.Copy
  ws.Cells(erow, 1).PasteSpecial
  ws.Columns("A:L").ColumnWidth = 14
  ws.Columns("C").AutoFit
  ws.Columns("N:CM").ColumnWidth = 14
  newBook.Save
  newBook.Close
End Sub

Answer 2

我明白了。谢谢！

Sub ProgramExport()

  Dim Program As Range
  Set Program = Range("C1:C2000")
  Dim rng As Range
  Dim wbThis As Workbook
  Dim newBook As Workbook
  Dim value As String
  Dim userID As String
  Dim fn As String
  Dim x As String

  Set newBook = Workbooks.Add

  value = InputBox("Please enter the program you'd like to export.")
  userID = InputBox("Please enter your user id.")
  fn = "C:\Users\" & userID & "\Desktop\" & value & ".xlsx"
  'aFN = "C:\Users\ashaikh5\Desktop\Copy of TS L2L3v11.xlsm"
  newBook.SaveAs (fn)

  x = "PROGRAM"

  For Each cell In Program

      If cell = value Or cell.value = x Then
          If rng Is Nothing Then
            Set rng = cell.EntireRow
          Else
            Set rng = Union(rng, cell.EntireRow)
          End If
      Else
          'cell.Font.ColorIndex = 3

  End If

  Next
  Dim ws As Worksheet: Set ws = newBook.Worksheets(1)
  erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  rng.Copy
  ws.Cells(erow, 1).PasteSpecial
  ws.Columns("A:L").ColumnWidth = 14
  ws.Columns("C").AutoFit
  ws.Columns("N:CM").ColumnWidth = 14
  newBook.Save
  Set wbThis = Workbooks("TS L2L3v11.xlsm")
  'wbThis.Activate
  Dim test As Worksheet: Set test = wbThis.Worksheets(5)
  test.Rows(2).Copy
  ws.Cells(1, 1).PasteSpecial
  newBook.Close


End Sub

Excel将行复制到另一个工作簿

2 个答案: