Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Correr Range atravé...
 
Notifications
Clear all

Correr Range através de ColorIndex

 
2024 - VBA & Macros
2 Posts
2 Usuários
0 Reactions
927 Visualizações
RSS
 joanas
(@joanas)
Posts: 48
Eminent Member
Topic starter
 

Bom dia,

estou a tentar criar uma macro que permita:

- percorrer uma range sem fim determinado de linhas nem colunas.. e sempre que encontrar uma célula amarela (ColorIndex = 36), para e copia essa célula (Exemplo: A1) e cola noutro worbook, na mesma célula (A1), o valor que essa célula contem

Exemplo:

workbook - Teste1
Sheet - Sheet1
Copia célula A1
Workbook - Teste2
Sheet - Sheet2
Cola célula A1 na célula A1 do Teste2

O que já fiz:
Sub CopiarColar()

'Dim Linha, Coluna As Integer
'Dim cel As Range
Dim FinalRow As Integer
Dim i As Integer
i = 0
FinalRow = Range("A65536").End(xlUp).Row

Coluna = Range("A65536").End(xlLeft).Column

Workbooks("Teste1.xlsm").Worksheets("Sheet1").Activate

Do While Linha <= FinalRow
If Cells(i + 1, 6).Interior.ColorIndex = 36 Then
Workbooks("Teste1.xlsm").Worksheets("Sheet1").Activate
Cells(i + 1, 6).Select
Selection.Copy
Workbooks("Teste2.xlsm").Worksheets("Sheet1").Activate
Cells(i + 1, 6).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If

i = i + 1

Loop

End Sub

agora falta-me percorrer por colunas, mas estou com duvidas

Alguém pode ajudar?

Obrigada

 
Postado : 19/01/2015 4:33 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Talvez assim??

Sub CopiarColar()

Dim FinalRow As Integer, Linha As Integer
Dim i As Integer, j As Integer
Dim wBook As Workbook

Set wBook = ThisWorkbook
wBook.Worksheets("Plan1").Activate
i = 0

For j = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column
FinalRow = Cells(Cells.Rows.Count, j).End(xlUp).Row

    For Linha = 1 To FinalRow
        If Cells(Linha, j).Interior.ColorIndex = 36 Then
        Cells(Linha, j).Select
        Selection.Copy
        Windows("Teste2.xlsm").Activate
        Sheets("Sheet1").Cells(Linha, j).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        wBook.Activate
        End If
    Next

Next

End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 19/01/2015 7:12 am
Forum Jump:
  Tópico Anterior
Próximo Tópico