copiere culoare fisier diferit

[magioaba]

Buna ziua, as avea si eu nevoie de ajutor cu o operatiune care imi ia mult timp. Primesc zilnic un raport care, fata de ziua anterioara, poate contine cateva linii in plus. Ideea este ca in cel din ziua anterioara am colorat anumite celule si as dori ca in fisierul de azi sa se preia culorile din fisierul anterior din coloana "Info". Va multumesc!

[Indigo-99]

Salut,

Ideea este ca in cel din ziua anterioara am colorat anumite celule si as dori ca in fisierul de azi sa se preia culorile din fisierul anterior din coloana "Info".

In ce sens, "sa se preia"? adica daca gaseste acelasi item in fisierul azi, sa coloreze celula respectiva din coloana info, tot randul din tabel sau tot randul din foaie?

Daca exista numar colorat dar nu se regaseste in fisierul "azi", ce sa faca?

[magioaba]

Salut. Da, exact. Daca găsește aceeași valoare în celălalt fișier, să îmi coloreze cu aceeasi culoare celula din fisierul actual. E suficient doar celula din coloana Info.
Daca găsește ceva ce anterior a fost colorat dar în fișierul altual nu există, să nu facă nimic. Sa se limiteze strict la valorile tabelului din ziua respectiva, nu la cea anterioara.

[DR.ACCESS]

Buna,
eu am descarcat ambele fisiere si nu vad nimic colorat ci doar doua tables cu optiunea "banded rows" activa. Despre ce culoare din fisierul initial este vorba?
Sau doriti sa se formateze celulele din fisierul actual daca datele se regasesc in cel vechi cu o culoare de evidentiere?

[DR.ACCESS]

Scuze, am vazut intr-un final ca aveti si celule colorate manual.
Ignorati mesajul anteior

[magioaba]

Nicio problemă. Îmi puteți spune dacă se poate face cumva?

[DR.ACCESS]

Buna,
am incercat ceva, nu stiu sigur daca mi-a reusit 100%.
E drept ca nu sunt cine stie ce expert asa ca nu am reusit cel mai rapid cod.
am folosit metoda getopenfilename ca sa puteti alege din orice locatie fisierul cu date vechi

Cod: Selectaţi tot

Sub coloare_actual()
Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim arr As Variant
    arr = Application.Transpose(ThisWorkbook.Sheets("data").ListObjects("Table1").ListColumns(1).DataBodyRange)

    Dim v_arr As Variant
    Dim wbk As Workbook
    numef = Application.GetOpenFilename

Set wbk = Workbooks.Open(numef)

v_arr = Application.Transpose(wbk.Sheets("data").ListObjects("Table1").ListColumns(1).DataBodyRange)

    Dim x As Variant
    Dim i As Long
    i = 0
    j = 2
    For Each x In arr
        
     If IsNumeric(Application.match(x, v_arr, 0)) Then
           i = Application.match(x, v_arr, 0) + 1
    ThisWorkbook.Sheets("data").Cells(j, 1).Interior.Color = wbk.Sheets("data").Cells(i, 1).Interior.Color
        End If
 j = j + 1
    Next
     wbk.Close

Application.ScreenUpdating = True
End Sub

[magioaba]

Functioneaza perfect! Va multumesc!!!