Cod VBA pentru copierea anumitor coloane din mai multe sheet
-
- Mesaje: 44
- Membru din: Dum Aug 27, 2017 4:37 pm
Cod VBA pentru copierea anumitor coloane din mai multe sheet
Buna ziua,
as dori un ajutor la centralizarea(cu ajutorul unui cod VBA) unor coloane din mai multe sheeturi cu aceeasi structura,in sheet "Centralizare".Pecizez ca vreau sa se copieze doar din sheeturile din dreapta sheetului "Centralizare".
Multumesc fromos!
as dori un ajutor la centralizarea(cu ajutorul unui cod VBA) unor coloane din mai multe sheeturi cu aceeasi structura,in sheet "Centralizare".Pecizez ca vreau sa se copieze doar din sheeturile din dreapta sheetului "Centralizare".
Multumesc fromos!
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
Re: Cod VBA pentru copierea anumitor coloane din mai multe s
Buna,
Aveti mai jos un cod care:
- memoreaza si copiaza toate denumirile din capul tabelului centralizator
- identifica foile ce contin date sursa dupa o lista setata
- copiaza in tabelul centralizator toate liniile din foile sursa pana intaneste prima celula goala pe coloana "Nr." (adica prima denumire din header)
Nu ati specificat insa cum veti folosi aceasta centralizare (cumulativa sau cu suprascriere). Deci, in forma actuala, se vor adauga valorile din foi de cate ori apelati subrutina.
Aveti mai jos un cod care:
- memoreaza si copiaza toate denumirile din capul tabelului centralizator
- identifica foile ce contin date sursa dupa o lista setata
- copiaza in tabelul centralizator toate liniile din foile sursa pana intaneste prima celula goala pe coloana "Nr." (adica prima denumire din header)
Nu ati specificat insa cum veti folosi aceasta centralizare (cumulativa sau cu suprascriere). Deci, in forma actuala, se vor adauga valorile din foi de cate ori apelati subrutina.
Cod: Selectaţi tot
Sub centralizare()
'Definire date --------------------------------------------------------------------------------------------
Const DataSheets As String = "CC,BB,AA" 'denumirile foilor din care se extrag date
Const TotalSheet As String = "Centralizare" 'numele foii centralizatoare
Const TotalHeaderRow As Long = 2 'randul pe care se afla capul de tabel in foaia centralizatoare
Const DataHeaderRow As Long = 21 'randul pe care se afla capul de tabel in foile sursa
'----------------------------------------------------------------------------------------------------------
Dim ws As Worksheet, wsT As Worksheet
Dim arrHeader() As String
Dim rTot As Range
Dim i As Long, col As Long
Dim k As Integer
'identificare cap tabel centralizator si memorare denumiri
Set wsT = ThisWorkbook.Sheets(TotalSheet)
With wsT.Rows(TotalHeaderRow)
Do
col = col + 1: Loop While Len(.Cells(col).Value) = 0
Do While Len(.Cells(col + k).Value) > 0
ReDim Preserve arrHeader(1 To 2, 1 To k + 1): arrHeader(1, k + 1) = .Cells(col + k).Value
k = k + 1: Loop
End With
Application.ScreenUpdating = False
'culegere date
For Each ws In ThisWorkbook.Worksheets
If InStr(1, DataSheets, ws.Name) > 0 Then
For k = 1 To UBound(arrHeader, 2)
Set rTot = ws.Rows(DataHeaderRow).Find(what:=arrHeader(1, k))
If Not rTot Is Nothing Then arrHeader(2, k) = rTot.Column
Next k
i = 1
Do While Len(ws.Cells(DataHeaderRow + i, Val(arrHeader(2, 1))).Value) > 0
Set rTot = wsT.Cells(wsT.Rows.Count, col).End(xlUp).Offset(1, 0)
rTot.Value = rTot.Row - TotalHeaderRow
For k = 2 To UBound(arrHeader, 2)
rTot.Offset(, k - 1).Value = ws.Cells(DataHeaderRow + i, Val(arrHeader(2, k))).Value
Next k
i = i + 1
Loop
End If
Next ws
Application.ScreenUpdating = True
Set wsT = Nothing
If Not ws Is Nothing Then Set ws = Nothing
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
Am invatat sa inotam in apa, ca pestii
Am invatat sa zburam in aer, ca pasarile
A ramas doar sa invatam sa traim pe Pamant, ca Oamenii.
Am invatat sa zburam in aer, ca pasarile
A ramas doar sa invatam sa traim pe Pamant, ca Oamenii.
-
- Mesaje: 44
- Membru din: Dum Aug 27, 2017 4:37 pm
Re: Cod VBA pentru copierea anumitor coloane din mai multe s
Multumesc frumos!Abia astept sa-l testez
-
- Mesaje: 44
- Membru din: Dum Aug 27, 2017 4:37 pm
Re: Cod VBA pentru copierea anumitor coloane din mai multe s
M-am uitat , am testat, dar mai am o rugaminte.Deoarece vor fi multe sheeturi,si pentru a nu denumi in VBA fiecare sheet, nu se poate sa adune toate sheeturile care vor fi in dreapta centralizarii, indiferent de numele sheetului?
Multumesc!
Multumesc!
Re: Cod VBA pentru copierea anumitor coloane din mai multe s
Cod: Selectaţi tot
Sub centralizare()
'Definire date --------------------------------------------------------------------------------------------
Const TotalSheet As String = "Centralizare" 'numele foii centralizatoare
Const TotalHeaderRow As Long = 2 'randul pe care se afla capul de tabel in foaia centralizatoare
Const DataHeaderRow As Long = 21 'randul pe care se afla capul de tabel in foile sursa
'----------------------------------------------------------------------------------------------------------
Dim ws As Worksheet, wsT As Worksheet
Dim arrHeader() As String
Dim rTot As Range
Dim i As Long, col As Long
Dim k As Integer
'identificare cap tabel centralizator si memorare denumiri
Set wsT = ThisWorkbook.Sheets(TotalSheet)
With wsT.Rows(TotalHeaderRow)
Do
col = col + 1: Loop While Len(.Cells(col).Value) = 0
Do While Len(.Cells(col + k).Value) > 0
ReDim Preserve arrHeader(1 To 2, 1 To k + 1): arrHeader(1, k + 1) = .Cells(col + k).Value
k = k + 1: Loop
End With
Application.ScreenUpdating = False
'culegere date
For Each ws In ThisWorkbook.Worksheets
If ws.Index > ThisWorkbook.Worksheets(TotalSheet).Index Then
For k = 1 To UBound(arrHeader, 2)
Set rTot = ws.Rows(DataHeaderRow).Find(what:=arrHeader(1, k))
If Not rTot Is Nothing Then arrHeader(2, k) = rTot.Column
Next k
i = 1
Do While Len(ws.Cells(DataHeaderRow + i, Val(arrHeader(2, 1))).Value) > 0
Set rTot = wsT.Cells(wsT.Rows.Count, col).End(xlUp).Offset(1, 0)
rTot.Value = rTot.Row - TotalHeaderRow
For k = 2 To UBound(arrHeader, 2)
rTot.Offset(, k - 1).Value = ws.Cells(DataHeaderRow + i, Val(arrHeader(2, k))).Value
Next k
i = i + 1
Loop
End If
Next ws
Application.ScreenUpdating = True
Set wsT = Nothing
If Not ws Is Nothing Then Set ws = Nothing
End Sub
Am invatat sa inotam in apa, ca pestii
Am invatat sa zburam in aer, ca pasarile
A ramas doar sa invatam sa traim pe Pamant, ca Oamenii.
Am invatat sa zburam in aer, ca pasarile
A ramas doar sa invatam sa traim pe Pamant, ca Oamenii.
-
- Mesaje: 44
- Membru din: Dum Aug 27, 2017 4:37 pm
Re: Cod VBA pentru copierea anumitor coloane din mai multe s
Multumesc mult!
-
- Mesaje: 44
- Membru din: Dum Aug 27, 2017 4:37 pm
Re: Cod VBA pentru copierea anumitor coloane din mai multe s
Mai am o rugaminte, un cod vba pentru copierea in sheet "LISTA" a contestatiilor( sa nu apara si cele cu zero sau necompletate).
Multumesc frumos de ajutor!
Multumesc frumos de ajutor!
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.