Pivot table prin multiple fisiere

[entiu]

Merge perfect.
Am mai invat ceva cu ocazia asta.
Multumesc mult.

[entiu]

La codul de mai jos se poate realiza sa copieze si comentariul care se regaseste in celule?

Multumesc.

Buna ziua

Codul propus de mine plecase de la premisa ca in tabelele respective aveti valori, nu formule/link-uri catre alte foi. Codul efectua o operatiune de copiere completa, asadar se copiau astfel (si) formule/linkuri, formatari etc.

Inlocuiti codul vechi cu codul de mai jos si efectuati niste testari. In esenta am inlocuit copierea totala cu copierea doar a valorilor

Cod: Selectaţi tot

Sub ExtrageInfo()

'IPP - 09.04.2014

Application.ScreenUpdating = False

Dim MyFolder As String
Dim MyFile As String
Dim dataCalend As Date

MyFolder = Application.ThisWorkbook.Path + "\Sursa\"
MyFile = Dir(MyFolder + "*.xls*")

Sheets("db").Select

Do While MyFile <> ""
 Workbooks.Open Filename:=MyFolder + MyFile
  
dataCalend = DateValue(Mid(MyFile, 7, 4) + "/" + Mid(MyFile, 4, 2) + "/" + Left(MyFile, 2))
   
 Sheets("Sheet1").Select
   Range("A2:C7").Copy
   ThisWorkbook.Activate
   Sheets("db").Select
   Range("A65536").End(xlUp).Offset(1, 0).Select
   Selection.PasteSpecial Paste:=xlValues
   
 Application.CutCopyMode = False
 
 Windows(MyFile).Activate
     
Application.DisplayAlerts = False
    ActiveWindow.Close
Application.DisplayAlerts = True

Range("D65536").End(xlUp).Offset(1, 0).Select
Do Until IsEmpty(ActiveCell.Offset(0, -1))
 ActiveCell = dataCalend
 ActiveCell.Offset(1, 0).Select
Loop

MyFile = Dir
Loop

Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous

Application.ScreenUpdating = True
End Sub

IP

[IPP]

Buna ziua

Incercati sa testati adaugand si instructiunea:

Cod: Selectaţi tot

Selection.PasteSpecial Paste:=xlPasteComments

IP

[entiu]

Functioneaza. Multumesc mult.

Buna ziua

Incercati sa testati adaugand si instructiunea:

Cod: Selectaţi tot

Selection.PasteSpecial Paste:=xlPasteComments

IP