Cod VBA pentru copierea anumitor coloane din mai multe sheet

[verbavolant]

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!

[TudyBTH]

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.

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

[verbavolant]

Multumesc frumos!Abia astept sa-l testez

[verbavolant]

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!

[TudyBTH]

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

[verbavolant]

Multumesc mult!

[verbavolant]

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!