Início / coding / Perguntas / 79556233
Accepted
Matheus Lors
Asked: 2025-04-05 04:52:14 +0800 CST

Como selecionar e copiar conteúdos específicos para outras tabelas

  • 772

Estou tentando copiar todas as linhas definidas como "Masculino" ou "Feminino", dependendo da escolha do usuário, como um estudo e teste de conceito para meu trabalho. No entanto, quando tento executar o código, ele repete a primeira linha para a quantidade de linhas que há na tabela principal ou não copia nada se eu selecionar "Feminino".

Meu código é:

    Sub Seletion()

Dim CatDes As String
Dim Bsd As Excel.Worksheet
Dim Tst As Excel.Worksheet
Dim NR As Integer
Dim i As Integer
Dim N As Integer

'Variables
CatDes = Sheets("issue sheet").Range("B2").Value
Set Bsd = Excel.Worksheets("Base de dados")
NR = Bsd.Range("a1").End(xlDown).Row - 1
N = 2

'Copy headers
Bsd.Select
Range("A1", Range("A1").End(xlToRight)).Copy
Sheets.Add.Name = "Teste"
    'Criar planilha nova
        Set Tst = Excel.Worksheets("Teste")
        Tst.Range("A1").PasteSpecial Paste:=xlPasteValues

'Copy info
While N <> NR

Bsd.Select
Bsd.Cells(N, 1).Select
    Do
        If ActiveCell.Offset(0, 4).Value = CatDes Then
            Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.End(xlToRight).Column)).Copy
            Tst.Select
            Range("A1").Select
                'Checar Próxima Celula Vazia
            Do While Not IsEmpty(ActiveCell)
                ActiveCell.Offset(1, 0).Select
            Loop
            ActiveCell.PasteSpecial xlPasteValues
            Else
        End If
        N = N + 1
    Loop Until N = NR
Wend
    
End Sub

A ideia é que eu:

  1. Tenho o gênero que desejo selecionado/digitado (CatDes)
  2. Saiba quantas linhas existem no banco de dados principal (NR)
  3. Copie os cabeçalhos do banco de dados principal (já que meu objetivo é criar uma nova planilha como um todo em vez de filtrá-la)
  4. Copie todas as linhas que tenham o gênero exato que selecionei.

Tentei repetir o processo de verificação de gênero tantas vezes quantas forem as linhas no banco de dados principal, mas não tenho certeza se há uma maneira melhor para isso, daí o "N<>NR". Tentei usar o For I ... Next, mas não tive sucesso. Qualquer ajuda é apreciada

excel

1 respostas

  1. Best Answer

    Copiar linhas filtradas como valores

    Sub CopyFilteredValues()

    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Retrieve the criteria from the lookup sheet.
    Dim lws As Worksheet: Set lws = wb.Sheets("Issue Sheet")
    Dim Criteria As String: Criteria = CStr(lws.Range("B2").Value)
    
    ' Return the values of the source table range in an array.
    Dim sws As Worksheet: Set sws = wb.Sheets("Base de dados")
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim sRowsCount As Long: sRowsCount = srg.Rows.Count
    Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
    If ColumnsCount < 5 Then Exit Sub ' 5 is the criteria column
    Dim Data() As Variant: Data = srg.Value
    Dim IsHeaderRow As Boolean: IsHeaderRow = True
    
    ' Declare addtional variables.
    Dim sRow As Long, dRow As Long, Col As Long, AreRowsDifferent As Boolean
    
    ' Loop through the rows of the array and move the matching rows
    ' to the top.
    For sRow = 1 To sRowsCount
        If IsHeaderRow Then
            dRow = dRow + 1
            IsHeaderRow = False
        Else
            If StrComp(CStr(Data(sRow, 5)), Criteria, vbTextCompare) = 0 Then
                dRow = dRow + 1
                If Not AreRowsDifferent Then
                    If dRow < sRow Then AreRowsDifferent = True
                End If
                If AreRowsDifferent Then
                    For Col = 1 To ColumnsCount
                        Data(dRow, Col) = Data(sRow, Col)
                    Next Col
                End If
            End If
        End If
    Next sRow
    
    ' Add or clear the destination sheet.
    Dim dws As Worksheet:
    On Error Resume Next
        Set dws = wb.Sheets("Teste")
    On Error GoTo 0
    If dws Is Nothing Then
        Set dws = wb.Sheets.Add
        dws.Name = "Teste"
    Else
        dws.Cells.Clear
    End If
    
    ' Copy the values from the top of the array to the destination sheet.
    dws.Range("A1").Resize(dRow, ColumnsCount).Value = Data
    
    ' Inform.
    If dRow = 1 Then
        MsgBox "No rows matching """ & Criteria & """ found!", vbExclamation
    Else
        MsgBox "Copied rows matching """ & Criteria & """.", vbInformation
    End If
    
End Sub
    • 0

relate perguntas