将多个Excel表合并到摘要表中 [英] Merge Multiple Excel Sheets Into Summary Sheet

问题描述

我正在使用以下代码，允许用户从多个Excel工作簿复制并合并数据进入摘要表。

  Sub Merge（）
 Dim DestWB As Workbook，WB As Workbook，WS As Worksheet ，SourceSheet As String 
 
设置DestWB = ActiveWorkbook 
 SourceSheet =Input
 startrow = 7 
 FileNames = Application.GetOpenFilename（_ 
 filefilter：= Excel文件（* .xls *），*。xls *，_ 
标题：=选择要合并的工作簿，MultiSelect：= True）
如果IsArray（FileNames）= False 
如果FileNames = False然后
退出Sub 
 End If 
 End If 
对于n = LBound（FileNames）到UBound（FileNames）
设置WB = Workbooks.Open（文件名：= FileNames（n），ReadOnly：= True）
对于每个WS在WB.Worksheets 
如果WS.Name = SourceSheet然后
与WS 
如果.UsedRange.Cells.Count> 1然后
 dr = DestWB.Worksheets（Input）。Range（C& Rows.Count）.End（xlUp）.Row + 1 
 lastrow = .Range（C& ; Rows.Count）.End（xlUp）.Row 
对于j = lastrow启动步骤-1 
如果Range（E& j） 需求经理和范围（E& j） R& D Lead和Range（E& j） 技术和范围（E& j） AnalystThen Rows（j）.Delete 
 Next 
 lastrow = .Range（C& Rows.Count）.End（xlUp）.Row 
如果lastrow> = startrow然后
 .Range（A& startrow&：AQ& lastrow）.Copy 
 DestWB.Worksheets（Input）。单元格（dr，A）PasteSpecial xlValues 
结束如果
结束如果
结束
退出
结束如果
下一个WS 
 WB.Close savechanges：= False 
下一步n 
 End Sub 
  

代码工作正常，但我遇到问题与复制信息有关，这是这一行代码：

  .Range（A& startrow& ：AQ& lastrow）.Copy 
  

我需要更改这个它考虑到两个范围。这些列是B：AD和AF：AQ，但我不知道该怎么做。

我只是想知道有人可能会采取请看这个，并提供一些关于我如何解决这个问题的指导。

非常感谢和善意

解决方案

在以下所有内容中，我假设您确实不要将列A复制到目标工作簿和工作表。

您可以使用 Union 复制粘贴一次（然后粘贴之间的任何列都不会被反映：

 如果lastrow> = startrow然后
联合（.Range（B& startrow&：AD& ），.Range（AF& startrow&：AQ& lastrow）.Copy 
 DestWB.Worksheets（Input）。Cells（dr，B）。PasteSpecial xlValues 
如果
  

如果你想要在它之间粘贴空格，那么你可以简单地复制和粘贴线条：

 如果lastrow> = startrow然后
 .Range（B&开始与：AD& （AF&;AQ& lastrow）。 ）.Copy 
 DestWB.Worksheets（Input）。Cells（dr，AF）。PasteSpecial xlValues 
 End If 
  

I wonder whether someone may be able to help me please.

I'm using the code below to allow the user to copy from multiple Excel workbooks and merge the data into a Summary sheet.

Sub Merge()
        Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String

        Set DestWB = ActiveWorkbook
        SourceSheet = "Input"
        startrow = 7
        FileNames = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xls*),*.xls*", _
        Title:="Select the workbooks to merge.", MultiSelect:=True)
        If IsArray(FileNames) = False Then
            If FileNames = False Then
                Exit Sub
            End If
        End If
        For n = LBound(FileNames) To UBound(FileNames)
            Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
            For Each WS In WB.Worksheets
                If WS.Name = SourceSheet Then
                    With WS
                        If .UsedRange.Cells.Count > 1 Then
                            dr = DestWB.Worksheets("Input").Range("C" & Rows.Count).End(xlUp).Row + 1
                            lastrow = .Range("C" & Rows.Count).End(xlUp).Row
                            For j = lastrow To startrow Step -1
                                If Range("E" & j) <> "Requirements Manager" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
                            Next
                            lastrow = .Range("C" & Rows.Count).End(xlUp).Row
                            If lastrow >= startrow Then
                                .Range("A" & startrow & ":AQ" & lastrow).Copy
                                DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial xlValues
                            End If
                        End If
                    End With
                    Exit For
                End If
            Next WS
            WB.Close savechanges:=False
        Next n
    End Sub

The code works fine but I'm stuck with a problem related to the copying of the information, which is this line of code:

  .Range("A" & startrow & ":AQ" & lastrow).Copy

I need to change this so that it takes into account two ranges. These are columns "B:AD" and "AF:AQ", but I'm not sure how to do this.

I just wondered wehether someone could possibly take a look at this please and offer some guidance on how I may go about solving this.

Many thanks and kind regards

解决方案

In all the following I assume that you indeed don't want column A copied to the destination workbook and sheet.

You could use Union to copy paste it in one go (then any columns in between it will not be reflected when pasting:

                        If lastrow >= startrow Then
                            Union(.Range("B" & startrow & ":AD" & lastrow), .Range("AF" & startrow & ":AQ" & lastrow).Copy
                            DestWB.Worksheets("Input").Cells(dr, "B").PasteSpecial xlValues
                        End If

If you want it pasted with room between it as well then you could simply r3epeat the copy and paste lines:

                        If lastrow >= startrow Then
                            .Range("B" & startrow & ":AD" & lastrow).Copy
                            DestWB.Worksheets("Input").Cells(dr, "B").PasteSpecial xlValues
                            .Range("AF" & startrow & ":AQ" & lastrow).Copy
                            DestWB.Worksheets("Input").Cells(dr, "AF").PasteSpecial xlValues
                        End If

这篇关于将多个Excel表合并到摘要表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！