Copiere informatii gasite cu "Find" in alt fisier

[gh19612005]

Buna ziua!
Dupa cateva zile de incercari (bine, se zice ca am muncit si pentru servici), am "emanat" codul atasat, care, se vede cu ochiul liber, nu e de loc profesionist si nici nu face tot ceea ce mi-am propus:
-nu copiaza toate instantele din fiecare foaie
-nu am stiut cum sa-l fac sa-mi treaca data raportului inaintea fiecarui calup copiat (initial ma gandisem sa trec numele foii dar apoi mi-am dat seama ca am aceasta data in fiecare foaie, in celula "C6")
-apoi va trebui sa scriu codul pentru mutare in registru nou si sa-l salvez cu numele dorit.

Cod: Selectaţi tot

Sub Cauta_sir_si_copiaza_calup()

Sir = VBA.InputBox("Introdu sirul de cautat")

Application.ScreenUpdating = False

For sh = 2 To ThisWorkbook.Worksheets.Count

   
   On Error Resume Next
   
   
    Sheets(sh).Select
   
    Cells.Find(What:=Sir, After:=ActiveCell, LookIn:=xlValues _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
    
   ActiveCell.Select
    'Ma intereseaza doar daca Sir-ul de cautat e pe coloana "B"
    If ActiveCell.Column = 2 Then
    ActiveCell.Offset(-6, -1).Range("A1:N29").Select
    Selection.Copy
    
    'Coloana "N" este intotdeauna plina - in zona calupului
    With Sheets(1).Range("N1000000").End(xlUp).Offset(1, -13)
   .PasteSpecial xlPasteFormats
   .PasteSpecial xlPasteValues
    End With
    End If
    
    Cells.FindNext(After:=ActiveCell).Activate
   
   
Next sh
 Sheets(1).Select
Application.ScreenUpdating = True

End Sub

[csaba1960]

Buna
Eu as propune o alta abordare.
Aici, http://www.cpearson.com/excel/findall.aspx este o functie cate permite cautarea intr-un Workbook, in pagini specificate sau toate paginiile, in acelasi Range( coloana B in acest caz).
Rezultatul se poate scrie de ex. intr-o pagina, dupa care, iei fiecare adresa in parte, extinzi zona de copiere si faci Copy-Paste.

[gh19612005]

Buna ziua!
S-ar putea sa-i fi dat de cap. Multumita sugestiilor lui IPP si csaba1960.
Desigur, codul poate fi optimizat...eu atat m-am priceput.

Inca o data mii de multumiri celor ce si-au consumat timpul cu ... mine

Cod: Selectaţi tot

Sub Cauta_sir_si_copiaza_calup()
    Sheets(1).Cells.Select
    Selection.Clear
    Sheets(1).Name = "Tabelle1"

Sir = VBA.InputBox("Introdu sirul de cautat")

Application.ScreenUpdating = False

For sh = 2 To ThisWorkbook.Worksheets.Count

    Sheets(sh).Select
   
   
'Procedura de cautare

Dim FoundCell As Range
Dim LastCell As Range
Dim FirstAddr As String
With Range("B1:B500")
    Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = Range("b1:b500").Find(what:=Sir, after:=LastCell)

If Not FoundCell Is Nothing Then
    FirstAddr = FoundCell.Address
End If
Do Until FoundCell Is Nothing
    'scrie data
    Sheets(sh).Range("C6").Copy
    With Sheets(1).Range("n1000000").End(xlUp).Offset(1, -12)
   .PasteSpecial xlPasteValues
   .PasteSpecial xlPasteFormats
    End With
    'scrie calup
   FoundCell.Offset(-6, -1).Range("A1:N29").Select
   Selection.Copy
    
    With Sheets(1).Range("n1000000").End(xlUp).Offset(2, -13)
   .PasteSpecial xlPasteValues
   .PasteSpecial xlPasteFormats

    End With
    
    'a
    'a
    'Debug.Print FoundCell.Address
    Set FoundCell = Range("b1:b500").FindNext(after:=FoundCell)
    If FoundCell.Address = FirstAddr Then
        Exit Do
    End If
Loop
 
    
    Cells.FindNext(after:=ActiveCell).Activate
   
   
Next sh
 Sheets(1).Select
 Sheets(1).Name = Sir
 Sheets(1).Copy
 
 
Application.ScreenUpdating = True
 
End Sub

[gh19612005]

Buna ziua!
Revin ca sa va mai cer un sfat:
Cum ar trebui modificata secventa de mai jos ca sa pot copia si lipi si o imagine care s-ar afla in domeniul copiat?
Multumesc!

Cod: Selectaţi tot

   'scrie calup
   FoundCell.Offset(-6, -1).Range("A1:N29").Select
   Selection.Copy
    
    With Sheets(1).Range("n1000000").End(xlUp).Offset(2, -13)
   .PasteSpecial xlPasteValues
   .PasteSpecial xlPasteFormats

    End With