首页 文章

将多个表格中的行复制为一个,然后按列排序

提问于
浏览
0

我正在尝试创建一个单独的VBA,在E列中搜索七个不同的工作表以查找特定条目,然后将整行复制到第8个工作表中,并按列A顺序放置它们 .

我明白了它要搜索一个电子表格并将这些项目复制到另一个电子表格中它们位于电子表格的完全相同的行中

Sub Test()
    Dim rw As Long, Cell As Range
    For Each Cell In Tues.Range("E:E")
    rw = Cell.Row
     If Cell.Value = "No" Then
      Cell.EntireRow.Copy
       Sheets("Completed").Range("A" & rw).PasteSpecial
     End If
    Next
End Sub

我想搜索的电子表格是:周一周二周三周四周五周六周日

我要将其移动到的工作表称为 Completed ,然后我希望它按列A排序 .

有任何想法吗?

3 回答

  • 0

    这个怎么样:

    Sub loop_through_WS()
    Dim rw As Long, i As Long, lastRow As Long, compLastRow&
    Dim cel     As Range
    Dim mainWS As Worksheet, ws As Worksheet
    Dim sheetArray() As Variant
    
    sheetArray() = Array("Mon", "Tues", "Weds", "Thurs", "Fri", "Sat", "Sun")
    
    Set mainWS = Sheets("Completed")
    
    compLastRow = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).row
    
    For i = LBound(sheetArray) To UBound(sheetArray)
        With Sheets(sheetArray(i))
            lastRow = .Cells(.Rows.Count, 5).End(xlUp).row
            For Each cel In .Range("E1:E" & lastRow)
                rw = cel.row
                If cel.Value = "No" Then
                    cel.EntireRow.copy
                    mainWS.Range("A" & compLastRow).pasteSpecial
                    compLastRow = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).row + 1
                End If
            Next
        End With
    Next i
    
    Application.CutCopyMode = False
    
    End Sub
    

    它基本上使用你给出的代码,但我添加了工作表循环(它将循环遍历每一天的工作表)并粘贴回“已完成”的WS .

    看看你是否可以解决我在工作表中的循环问题 - 我经常使用这种类型的东西,所以如果你做了很多这样的事情,那就好了 . 它还允许您在工作簿中添加另一个工作表(比如“Weekend”),所有您需要做的就是在Array中的“Sun”之后添加“Weekend” . 这是你需要添加它的唯一地方 .

    需要注意的是,我将 for each Cell in Range(E:E)E1 更改为E列中的最后一行 - 这使得宏运行速度更快 .

    编辑:正如我在上面的评论中所提到的,通常不建议使用 Cell 作为变量名 . (同样适用于 ColumnRowRange 等)因为这些都意味着特别针对VBA(即 Cell([row],[column]) . 相反,如您所见,我喜欢使用 celrngiCell 等 .

  • 0

    根据你所描述的内容,这样的东西应该适合你 . 它使用For Each循环遍历工作表并使用AutoFilter方法从列E中查找它正在查找的内容 . 代码假定 Headers 位于每个工作表的第1行 . 为了清楚起见,我试图评论它 .

    Sub tgr()
    
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim wsCompleted As Worksheet
        Dim bHeaders As Boolean
    
        Set wb = ActiveWorkbook
        Set wsCompleted = wb.Sheets("Completed")
        bHeaders = False
    
        'Comment out or delete the following line if you do not want to clear current contents of the Completed sheet
        wsCompleted.Range("A2", wsCompleted.Cells(Rows.Count, Columns.Count)).Clear
    
        'Begin loop through your sheets
        For Each ws In wb.Sheets
            'Only perform operation if sheet is a day of the week
            If InStr(1, " Mon Tue Wed Thu Fri Sat Sun ", " " & Left(ws.Name, 3) & " ", vbTextCompare) > 0 Then
    
                'If headers haven't been brought in to wsCompleted yet, copy over headers
                If bHeaders = False Then
                    ws.Rows(1).EntireRow.Copy wsCompleted.Range("A1")
                    bHeaders = True
                End If
    
                'Filter on column E for the word "No" and copy over all rows
                With ws.Range("E1", ws.Cells(ws.Rows.Count, "E").End(xlUp))
                    .AutoFilter 1, "no"
                    .Offset(1).Resize(.Rows.Count - 1).EntireRow.Copy wsCompleted.Cells(wsCompleted.Rows.Count, "A").End(xlUp).Offset(1)
                    .AutoFilter
                End With
    
            End If
        Next ws
    
        'Sort wsCompleted by column A
        wsCompleted.Range("A1").CurrentRegion.Sort wsCompleted.Range("A1"), xlAscending, Header:=xlGuess
    
    End Sub
    

    EDIT :这是包含代码的示例工作簿 . 当我运行代码时,它按预期工作 . 您的工作簿数据设置是否完全不同?

    https://drive.google.com/file/d/0Bz-nM5djZBWYaFV3WnprRC1GMnM/view?usp=sharing

  • 1

    之前发布的答案中有一些很棒的内容,但我认为这样可以让您完全掌握所需的内容,而且没有任何问题,速度也很快 . 我对数据的布局做了一些假设,但对它们进行了评论 . 让我知道事情的后续 .

    Sub PasteNos()
    
        Dim wsComp As Worksheet
        Dim vSheets() As Variant
    
        Application.ScreenUpdating = False
    
        vSheets() = Array("Mon", "Tues", "Weds", "Thurs", "Fri", "Sat", "Sun")
    
        Set wsComp = Sheets("Completed")
    
        For i = LBound(vSheets) To UBound(vSheets)
    
            With Sheets(vSheets(i))
    
                .AutoFilterMode = False
    
                .Range(.Range("E1"), .Cells(.Rows.Count, 5).End(xlUp)).AutoFiler 1, "No"
                'assumes row 1 has headers
                .Range(.Range("E2"), .Cells(.Rows.Count, 5).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Copy
    
                'pastes into next available row
                With wsComp
                    .Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'assumes copy values over
                End With
    
            End With
    
        Next i
    
        'assumes ascending order, headers in row 1, and that data is row-by-row with no blank rows
        wsComp.UsedRange.Sort 1, xlAscending, Header:=xlYes
    
        Application.ScreenUpdating = True
    
    End Sub
    

相关问题