Eu experimentei alguns VBA para classificar e copiar.
Veja o arquivo xlsm vinculado no final para mais informações.
Então, o que temos aqui é um código do VBA que ordena as informações originais (apenas copiando, sem tocar na lista original) em três novas tabelas.
O que faz:
- Passa por toda a tabela original
- Copia cada linha para uma tabela nova, predefinida e existente em uma planilha diferente.
O que não faz:
- Verifique se há duplicatas
- Cria novas tabelas
Inclui também uma macro para limpar as tabelas ordenadas. Isso também pode ser usado para limpar as tabelas antes de classificar uma segunda vez, para evitar duplicações.
Código de classificação (isso provavelmente pode ser melhorado, mas está ficando atrasado):
Sub sortToTables()
Dim i, iLastRow As Integer
Dim oLastRow As ListRow
Dim srcRow As Range
Dim Replaced As String, Burn As String, Repurpose As String
iLastRow = Worksheets("Sheet1").ListObjects("Table1").ListRows.Count
Replaced = "220 - Replaced Component"
Burn = "C990 - Advised to burn"
Repurpose = "130 - Repurpose"
Application.ScreenUpdating = False
For i = 1 To iLastRow
If Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13) = Replaced Then
Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
Set oLastRow = Worksheets("220").ListObjects("Table16").ListRows.Add
srcRow.Copy
oLastRow.Range.PasteSpecial xlPasteValues
ElseIf Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13) = Burn Then
Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
Set oLastRow = Worksheets("C990").ListObjects("Table17").ListRows.Add
srcRow.Copy
oLastRow.Range.PasteSpecial xlPasteValues
ElseIf Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13) = Repurpose Then
Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
Set oLastRow = Worksheets("130").ListObjects("Table18").ListRows.Add
srcRow.Copy
oLastRow.Range.PasteSpecial xlPasteValues
End If
Next
Application.ScreenUpdating = True
End Sub
Código para limpar as tabelas:
Sub ResetTable()
Dim tbl As ListObject, tbl2 As ListObject, tbl3 As ListObject
Set tbl = Worksheets("220").ListObjects("Table16")
Set tbl2 = Worksheets("C990").ListObjects("Table17")
Set tbl3 = Worksheets("130").ListObjects("Table18")
If tbl.ListRows.Count >= 1 Then
tbl.DataBodyRange.Delete
End If
If tbl2.ListRows.Count >= 1 Then
tbl2.DataBodyRange.Delete
End If
If tbl3.ListRows.Count >= 1 Then
tbl3.DataBodyRange.Delete
End If
End Sub
Arquivo: link
EDITAR
Atualize o código para fazer o que você comentou (acho):
Sub sortToTables()
Dim i, iLastRow As Integer
Dim oLastRow As ListRow
Dim srcRow As Range
Dim Replaced As String, Burn As String, Repurpose As String
iLastRow = Worksheets("Sheet1").ListObjects("Table1").ListRows.Count
Application.ScreenUpdating = False
For i = 1 To iLastRow
If Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 11) = "C-235" And _
Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 12) = "LC0001234" And _
(InStr(1, Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13), "220") Or _
InStr(1, Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13), "221")) Then
Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
Set oLastRow = Worksheets("220").ListObjects("Table16").ListRows.Add
srcRow.Copy
oLastRow.Range.PasteSpecial xlPasteValues
Else
Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
Set oLastRow = Worksheets("C990").ListObjects("Table17").ListRows.Add
srcRow.Copy
oLastRow.Range.PasteSpecial xlPasteValues
End If
Next
Application.ScreenUpdating = True
End Sub
Como você pode ver aqui, eu uso Instr para obter uma correspondência parcial em uma string, em vez de um valor absoluto, já que a célula contém mais do que apenas o número.
Se você quiser verificar, digamos, séries diferentes, você pode atribuir esse valor a uma variável e inserir o número serial que deseja classificar em uma caixa de texto.
Eu não me preocupei em renomear as folhas, mas eu só uso duas das folhas neste exemplo.
Esclarecimento sobre como escrever a instrução If - observe os parênteses ao redor de OR:
If ref(x,y) = "string" And ref(x,y2) = "another string" And (ref(x,y3) ="this" Or (ref(x,y3) ="that") Then
Do stuff
Else '(Or ElseIf)
Do something else
End If