Cod macro copiere si prelucrare date
Cod macro copiere si prelucrare date
Buna seara.Revin cu o rugaminte la voi cei care ma puteti ajuta.
Se da fisierul atasat care are 3-4 foi cu date dar din care ma intereseaza doar foaia "Calcul" in care datele sunt aduse cu ajutorul unor formule. Acest fisier se afla in circa 500 de exemplare in maai multe subdosare care se gasesc toate in acelasi dosar pe un server. Mai intai as dori sa pot copia toate aceste fisiere in calculatorul unde se face prelucrarea cu optiunea de a selecta dosarul sursa si dosarul destinatie.
Apoi as dori ca din fiecare foaie "Calcul" din cele 500 de fisiere sa fie copiate toate randurile cu date in coloanele A-E si lipite in foaia curenta din registrul care contine codul in colanele B-F iar in coloana A (doar in dreptul randurilor unde exista date in coloana B) sa se copieze valoarea din celula H4 sau denumirea fisierului din care se face copierea ex: "3234" sau "Mag 3234". Fisierul destinatie ar trebui mai intai golit de toate datele de pe colanele A-F pentru a nu aparea date duplicate. Fisierul obtinut va fi salvat apoi doar ca o foaie simpla de calcul si folosit pentru rapoarte cu ajutorul filtrerol si pivot table. Sper ca am fost desul de explicit si ca voi gasi pe cineva binevoitor sa ma ajute. Va multumesc
Se da fisierul atasat care are 3-4 foi cu date dar din care ma intereseaza doar foaia "Calcul" in care datele sunt aduse cu ajutorul unor formule. Acest fisier se afla in circa 500 de exemplare in maai multe subdosare care se gasesc toate in acelasi dosar pe un server. Mai intai as dori sa pot copia toate aceste fisiere in calculatorul unde se face prelucrarea cu optiunea de a selecta dosarul sursa si dosarul destinatie.
Apoi as dori ca din fiecare foaie "Calcul" din cele 500 de fisiere sa fie copiate toate randurile cu date in coloanele A-E si lipite in foaia curenta din registrul care contine codul in colanele B-F iar in coloana A (doar in dreptul randurilor unde exista date in coloana B) sa se copieze valoarea din celula H4 sau denumirea fisierului din care se face copierea ex: "3234" sau "Mag 3234". Fisierul destinatie ar trebui mai intai golit de toate datele de pe colanele A-F pentru a nu aparea date duplicate. Fisierul obtinut va fi salvat apoi doar ca o foaie simpla de calcul si folosit pentru rapoarte cu ajutorul filtrerol si pivot table. Sper ca am fost desul de explicit si ca voi gasi pe cineva binevoitor sa ma ajute. Va multumesc
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
Re: Cod macro copiere si prelucrare date
Am rezolvat prima parte aproblemei cu ajutorul codului de mai jos pe care l-am gasit pe internet si l-am adaptat.
Acum as dori sa import toate aceste fisiere intr-o singura fila in foaia de lucru care contine codul macro dupa regulile de mai sus. Va multumesc.
Cod: Selectaţi tot
Public Sub CopyFiles()
Dim sPathSource As String, sPathDest As String, sFileSpec As String
Dim Path1 As String, Path2 As String
Dim numTimes As Integer
sFileSpec = "*.xl**"
For numTimes = 1 To 1 'Change 2 to number of times you want to do the procedure.....
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
Path1 = .SelectedItems(1)
End If
End With
If Path1 <> "" Then
sPathSource = Path1
End If
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
Path2 = .SelectedItems(1)
End If
End With
If Path2 <> "" Then
sPathDest = Path2
End If
Call CopyFiles_FromFolderAndSubFolders(sFileSpec, sPathSource, sPathDest)
Next
End Sub
Public Sub CopyFiles_FromFolderAndSubFolders(ByVal argFileSpec As String, ByVal argSourcePath As String, ByRef argDestinationPath As String)
Dim sPathSource As String, sPathDest As String, sFileSpec As String
Dim FSO As Object
Dim oRoot As Object
Dim oFile As Object
Dim oFolder As Object
sPathSource = argSourcePath
sPathDest = argDestinationPath
If Not Right(sPathDest, 1) = "\" Then sPathDest = sPathDest & "\"
If Right(sPathSource, 1) = "\" Then sPathSource = Left(sPathSource, Len(sPathSource) - 1)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(sPathSource) And FSO.FolderExists(sPathDest) Then
Set oRoot = FSO.GetFolder(sPathSource)
For Each oFile In oRoot.Files
If LCase(oFile.Name) Like argFileSpec Then
On Error Resume Next
oFile.Copy sPathDest & oFile.Name
On Error GoTo 0
End If
Next oFile
For Each oFolder In oRoot.SubFolders
' == do the same for any folder ==
Call CopyFiles_FromFolderAndSubFolders(argFileSpec, oFolder.Path, sPathDest)
Next oFolder
End If
End Sub
Re: Cod macro copiere si prelucrare date
Buna
In atasament ai o posibila rezolvare.
Ce face?
La deschidere reseteza pagina de destinatie, mai putin capul de tabel.
Cu un FileDialog alegi folderul unde sunt fiserele. Programul deschide toate fiserele *.xlsx din folderul specificat. Din fisierul deschis din pagina Calcul se copiaza zona coloanelor "B:E", pana la ultimul rand cu date si se adauga la prima pagina din fisierul initial. Prima coloana se completeaza cu numele fiserului sursa.
Cam atat.
In atasament ai o posibila rezolvare.
Ce face?
La deschidere reseteza pagina de destinatie, mai putin capul de tabel.
Cu un FileDialog alegi folderul unde sunt fiserele. Programul deschide toate fiserele *.xlsx din folderul specificat. Din fisierul deschis din pagina Calcul se copiaza zona coloanelor "B:E", pana la ultimul rand cu date si se adauga la prima pagina din fisierul initial. Prima coloana se completeaza cu numele fiserului sursa.
Cam atat.
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
Re: Cod macro copiere si prelucrare date
Salut, multumesc pt. raspuns si imi cer scuze ca nu am venit cu un reply mai repede dar nu am avut timp sa il testez pana acum. Solutia propusa de tine e foarte buna cu o mica exceptie. Asa cum am specificat in descrierea problemei datele din celulele foii "calcul" sunt obtinute cu ajutorul unor formule ( IF Vlookup, etc ) din celelalte foi ale acelor fisiere, in solutia ta se copiaza acele formule si nu valoarea din celule. problema e ca in unele celule apare eroarea "#REF!" iar daca fisierele sursa sunt sterse apare peste tot eroare. De aceea as dori daca se poate sa fie copiata doar valoarea din celule nu si formula. Multumesc
Re: Cod macro copiere si prelucrare date
Buna
Revin cu modificarea facuta.
O zi buna.
Revin cu modificarea facuta.
O zi buna.
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
Re: Cod macro copiere si prelucrare date
Buna, am testat fisierul modificat si totul merge foarte bine dar a aparut o alta problema.Cand am incarcat fisierul exemplu am folosit un fisier cu doar cateva randuri pt. ca nu m-am gandit ca e vreo problema din moment ce se verifica ultimul rand cu date. In realitate fisierele au 400-500 de randuri iar cand rulez codul propus de tine dupa fiecare fisier apare o fereasta de avertizare ca am multe date in clipboard si daca doresc sale folosesc ulterior sau golesc memoria clipboard. Nu se poate goli aceasta memorie automat fara acea fereastra pentru ca daca doresc sa rulez acest fisier pt 500 de file ar trebui sa confirm dupa fiecare? Multumesc mult pt ajutor, o zi buna.
Re: Cod macro copiere si prelucrare date
Dupa mai multe testari am descoperit ca trebuie sa confirm salvarea datelor din memoria clipboard nu doar golirea memorie pentr a aveaun rezultat corect in fisierul final. Multumesc, o zi buna
Re: Cod macro copiere si prelucrare date
Buna
Incearca Application.DisplayAlerts = False la inceput si Application.DisplayAlerts = True la sfarsit, ar trebui sa ajute.
Incearca Application.DisplayAlerts = False la inceput si Application.DisplayAlerts = True la sfarsit, ar trebui sa ajute.
Re: Cod macro copiere si prelucrare date
Salut am incercat si merge solutia propusa. Mai am o mica problema si totul ar fi perfect.Cand incepe sa copieze din celelalte foi daca una dintre acele foi a fost inchisa pe alt sheet decat "Calcul" primesc un mesaj de eroare cu range-ul si se opreste procesarea fisiereleor. Cum as putea face ca sheetul activ din toate fisierele sa fie "Calcul" dupa deschiderea lor ? Multumesc mult.
Re: Cod macro copiere si prelucrare date
introduci un rand nou
Do While fiSier <> ""
nA = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row + 1:
Set sourCe = Workbooks.Open(aFolder & "\" & fiSier, ReadOnly = True): Set ws = sourCe.Sheets("Calcul"): ' deschid fiecare fisiser
primaCol = Mid(fiSier, 1, InStr(1, fiSier, ".") - 1) ' denumire fisier sursa
nS = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row: '
ws.Select
ws.Range(Cells(2, 2), Cells(nS, 5)).Copy: wsA.Cells(nA, 2).PasteSpecial Paste:=xlPasteValues: ' copiere
sourCe.Close
nB = wsA.Cells(wsA.Rows.Count, 2).End(xlUp).Row ' ' completare prima coloana
For i = nA To nB: wsA.Cells(i, 1) = primaCol: Next
fiSier = Dir
Loop
Do While fiSier <> ""
nA = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row + 1:
Set sourCe = Workbooks.Open(aFolder & "\" & fiSier, ReadOnly = True): Set ws = sourCe.Sheets("Calcul"): ' deschid fiecare fisiser
primaCol = Mid(fiSier, 1, InStr(1, fiSier, ".") - 1) ' denumire fisier sursa
nS = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row: '
ws.Select
ws.Range(Cells(2, 2), Cells(nS, 5)).Copy: wsA.Cells(nA, 2).PasteSpecial Paste:=xlPasteValues: ' copiere
sourCe.Close
nB = wsA.Cells(wsA.Rows.Count, 2).End(xlUp).Row ' ' completare prima coloana
For i = nA To nB: wsA.Cells(i, 1) = primaCol: Next
fiSier = Dir
Loop