Question

我在Book1的几个选项卡中有数据，当我运行宏（Book2中的按钮定位）时，我想将所有内容组合到Book2中的新工作表中。但是，它不仅仅是复制和粘贴。在我的书1中我有COL A：F包含用于G的相同信息：P某些COL是空白的。当组合数据时，我希望A：F重复（添加更多行），当G：P不为空时。然后填写G：P＆amp;的值K：每排N.

我已经附加了Book1，其中数据和Book2在运行宏之后我想要它的样子。有没有办法做到这一点？

Data - ＆gt; Result

提前谢谢！

我几乎就在那里。我已经创建了工作簿名称＆＃34; 2017培训数据库＆＃34;我得到了打开此工作簿的代码，将Sheet1从原始工作簿复制到此处。但是，我有超过1页要复制，所以我测试重复第二张的代码来做同样的事情（如果它工作我会做第三，第四，第五）。使用我到目前为止的代码它只将sheet1复制到sheet1但是sheet2到sheet2没有正确复制，只出现G1：H1。我到目前为止的守则

我已分别运行两组代码并且它们可以找到，当我将它们组合在一起时，第二个代码将无法正常运行。这是我的第一个代码 - ＆gt;打开工作簿并粘贴数据

    Private Sub CommandButton1_Click()
  'Code for open new workbook
  Dim wSht1 As Worksheet, wSht2 As Worksheet, wb As Workbook
  Dim r As Integer, r1 As Integer, r2 As Integer, c As Integer
  strPath2 = "S:\QCI\training\2017 Back Up\2017 Training Database.xlsx"

  Set wSht1 = Sheets("Sheet1")
  Set wb = Workbooks.Open(strPath2)
  Set wSht2 = wb.Sheets("Sheet1")

  With wSht1
    wb.Sheets("Sheet1").Cells.ClearContents
    r1 = .Cells(.Rows.Count, "A").End(xlUp).Row
    wSht2.Range("A1:F1").Value = .Range("A1:F1").Value
    wSht2.Cells(1, "G").Value = "Attendee"
    wSht2.Cells(1, "H").Value = "Category"
    r2 = 2

    For r = 2 To r1
      For c = 7 To 10
        If Not IsEmpty(.Cells(r, c)) Then
          wSht2.Range("A" & r2 & ":F" & r2).Value = .Range("A" & r & ":F" & r).Value
          wSht2.Cells(r2, 7).Value = .Cells(r, c).Value
          wSht2.Cells(r2, 8).Value = .Cells(r, c + 5).Value
          r2 = r2 + 1
        End If
      Next
    Next

  End With
End Sub

第二代码 - ＆gt;如果已打开的工作簿，则粘贴

Private Sub CommandButton3_Click()
Dim wSht1 As Worksheet, wSht2 As Worksheet, wb As Workbook
Dim r As Integer, r1 As Integer, r2 As Integer, c As Integer


  Set wSht1 = Sheets("Sheet2")
  Set wSht2 = Workbooks("2017 Training Database.xlsx").Worksheets("Sheet2")

  With wSht1
    wSht2.Cells.ClearContents
    r1 = .Cells(.Rows.Count, "A").End(xlUp).Row
    wSht2.Range("A1:F1").Value = .Range("A1:F1").Value
    wSht2.Cells(1, "G").Value = "Attendee"
    wSht2.Cells(1, "H").Value = "Category"
    r2 = 2

    For r = 2 To r1
      For c = 7 To 10
        If Not IsEmpty(.Cells(r, c)) Then
          wSht2.Range("A" & r2 & ":F" & r2).Value = .Range("A" & r & ":F" & r).Value
          wSht2.Cells(r2, 7).Value = .Cells(r, c).Value
          wSht2.Cells(r2, 8).Value = .Cells(r, c + 4).Value
          r2 = r2 + 1
        End If
      Next
    Next
  End With
End Sub

但是当我把它们放在一起时，第二个代码不能正常运行（并非所有数据都是粘贴的）。只有G1＆amp;出现H1，有什么想法吗？

Private Sub CommandButton4_Click()
'Code for open new workbook
  Dim wSht1 As Worksheet, wSht2 As Worksheet, wb As Workbook
  Dim r As Integer, r1 As Integer, r2 As Integer, c As Integer
  strPath2 = "S:\QCI\training\2017 Back Up\2017 Training Database.xlsx"

  Set wSht1 = Sheets("Sheet1")
  Set wb = Workbooks.Open(strPath2)
  Set wSht2 = wb.Sheets("Sheet1")

  With wSht1
    wb.Sheets("Sheet1").Cells.ClearContents
    r1 = .Cells(.Rows.Count, "A").End(xlUp).Row
    wSht2.Range("A1:F1").Value = .Range("A1:F1").Value
    wSht2.Cells(1, "G").Value = "Attendee"
    wSht2.Cells(1, "H").Value = "Category"
    r2 = 2

    For r = 2 To r1
      For c = 7 To 10
        If Not IsEmpty(.Cells(r, c)) Then
          wSht2.Range("A" & r2 & ":F" & r2).Value = .Range("A" & r & ":F" & r).Value
          wSht2.Cells(r2, 7).Value = .Cells(r, c).Value
          wSht2.Cells(r2, 8).Value = .Cells(r, c + 5).Value
          r2 = r2 + 1
        End If
      Next
    Next
  End With

  Set wSht1 = Sheets("Sheet2")
  Set wSht2 = Workbooks("2017 Training Database.xlsx").Worksheets("Sheet2")

  With wSht1
    wSht2.Cells.ClearContents
    r1 = .Cells(.Rows.Count, "A").End(xlUp).Row
    wSht2.Range("A1:F1").Value = .Range("A1:F1").Value
    wSht2.Cells(1, "G").Value = "Attendee"
    wSht2.Cells(1, "H").Value = "Category"
    r2 = 2

    For r = 2 To r1
      For c = 7 To 10
        If Not IsEmpty(.Cells(r, c)) Then
          wSht2.Range("A" & r2 & ":F" & r2).Value = .Range("A" & r & ":F" & r).Value
          wSht2.Cells(r2, 7).Value = .Cells(r, c).Value
          wSht2.Cells(r2, 8).Value = .Cells(r, c + 4).Value
          r2 = r2 + 1
        End If
      Next
    Next
  End With
End Sub

Answer 1

是的，有一种方法可以使用vba来实现，这应该可以让你开始。我假设您发布的图像的数据在Sheet1中，第1行中的标题行和第2行中的数据。以下子例程将根据您在Sheet2中发布的结果图像创建输出（您将拥有创造，如果它不存在）。将此宏加载到工作簿中，并在Sheet1中运行它。

Sub combineData()
  Dim wSht1 As Worksheet, wSht2 As Worksheet

  Dim r As Integer, r1 As Integer, r2 As Integer, c As Integer

  Set wSht1 = Sheets("Sheet1")
  Set wSht2 = Sheets("Sheet2")

  With wSht1
    r1 = .Cells(.Rows.Count, "A").End(xlUp).Row
    wSht2.Range("A1:F1").Value = .Range("A1:F1").Value
    wSht2.Cells(1, "G").Value = "Attendee"
    wSht2.Cells(1, "H").Value = "Category"
    r2 = 2

    For r = 2 To r1
      For c = 7 To 10
        If Not IsEmpty(.Cells(r, c)) Then
          wSht2.Range("A" & r2 & ":F" & r2).Value = .Range("A" & r & ":F" & r).Value
          wSht2.Cells(r2, 7).Value = .Cells(r, c).Value
          wSht2.Cells(r2, 8).Value = .Cells(r, c + 4).Value
          r2 = r2 + 1
        End If
      Next
    Next

  End With

End Sub

然而，要实现的是结果图像上显示的按钮，并按照原始问题将数据输出实际写入单独的工作簿。

修改

要写入新工作簿，请替换以下行：

Set wSht2 = Sheets("Sheet2")

使用：

Dim wb As Workbook Set wb = Application.Workbooks.Add Set wSht2 = wb.Sheets("Sheet1")

然后在End With之后和End Sub之前添加以下代码：

Dim name As String, saveFile As String saveFile = Application.GetSaveAsFilename name = saveFile & "xls" wb.SaveAs Filename:=name, FileFormat:=xlExcel8, CreateBackup:=False wb.Close

现在将打开一个新工作簿并将所有数据写入新工作簿（在Sheet1上），一旦完成，系统将提示您输入文件名。输入后，新工作簿将被保存并关闭。

将Book1中不同工作表的数据合并到Book2中的新工作表中，运行宏

1 个答案: