kopiranje kolona sa istim header-om iz vise sheet-ova u novi

[ gogi100 @ 16.05.2022. 08:46 ] @

imama sledeci kod, koji radi kopiranje kolona iz sheetova u novi, ali ovaj kod ne proverava da li su headeri isti u sheetovima. takodje, ako je raspored kolona razlicit, kod to ne proverava.

Code:

Sub Merge_Sheets()

Dim startRow, startCol, lastRow, lastCol As Long
Dim headers As Range
Dim ws As Worksheet
Dim pas As Worksheet

'Set Master sheet for consolidation
Set wb = ActiveWorkbook
pas = wb.ActiveSheet
Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "AllSheets"
Set mtr = Worksheets("AllSheets")
pas.Activate
'Get Headers
Set headers = Application.InputBox("Izaberi opseg Header-a", Type:=8)

'Copy Headers into master
headers.Copy mtr.Range("A1")
startRow = headers.Row + 1
startCol = headers.Column

Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
     'except the master sheet from looping
     If ws.Name <> "AllSheets" Then
        ws.Activate
        lastRow = Cells(Rows.Count, startCol).End(xlUp).Row
        lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
        'get data from each worksheet and copy it into AllSheets sheet
        Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
        mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)
           End If
Next ws

Sheets("AllSheets").Activate

End Sub

kako izmeniti ovaj kod da bih dobio ono sto zelim

[ Jpeca @ 16.05.2022. 14:41 ] @

Postoji alatka Consolidate koja omogućava kombinovanje listova po labelama Consolidate by Category
Ako to ne radi možeš koristiti power query da iskombinuješ tabele - tu je moguće promena imena i provera
https://www.youtube.com/watch?...Ik&ab_channel=LeilaGharani

[ gogi100 @ 16.05.2022. 16:26 ] @

meni treba makro u excel-u. da li se to moze uraditi?

[ Jpeca @ 17.05.2022. 09:08 ] @

Citat:

meni treba makro u excel-u. da li se to moze uraditi?

Naravno da može, ali su bitini jasni kriterijumi kako ćeš postupati u situaciji kad imaš različite labele (da li se višak ignoriše ili dodaje) i sl. - bez primera i detaljnijeg objašnjenja teškoje tačno znati

Neka moje mišljnje je da nema smisla razvijati makro ako imam gotov alat

[ gogi100 @ 17.05.2022. 11:57 ] @

kolone u svim sheetovima moraju biti sa istim headerima i to se kopira u novi sheet. ja sam nasao ovo resenje

Code:
Sub MasterMine()

Dim Master As Worksheet
Dim LR1 As Long, LR2 As Long, LC1 As Long, LC2 As Long
Dim ws As Worksheet
Dim Found As Range
Dim i As Long
Dim Arr() As Variant
Dim pas As Worksheet
Dim headers As Range
Dim SheetExists As Boolean
  'Set Master sheet for consolidation
  Set wb = ActiveWorkbook
  SheetExists = False
  Set pas = ActiveSheet
  For Each ws In ActiveWorkbook.Sheets
  If ws.Name = "AllSheets" Then
  SheetExists = True
  End If
  Next ws

  If SheetExists = False Then

    Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "AllSheets"
    Set Master = ActiveWorkbook.Sheets("AllSheets")
    pas.Activate
    'Get Headers
    Set headers = Application.InputBox("Izaberi opseg Header-a", Type:=8)
    'Copy Headers into master
    headers.Copy Master.Range("A1")
    LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
  ElseIf SheetExists = True Then

     Set Master = ActiveWorkbook.Sheets("AllSheets")
     pas.Activate
     LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
     If IsEmpty(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value) Then
        MsgBox "Postoji Sheet AllSheets, ali nema imena kolona. Unesite nazive kolona!"
        End
     End If
     If LC1 = 1 Then
     Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value
     Else
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
    End If

  End If

For Each ws In ActiveWorkbook.Sheets
    If ws.Name <> "AllSheets" Then

    For i = LBound(Arr) To UBound(Arr)
        LC2 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
         Set Found = ws.Range(ws.Cells(1, 1), ws.Cells(1, LC2)).Find(Arr(i), LookIn:=xlValues)
            If Not Found Is Nothing Then
                LR1 = Master.Cells(Master.Rows.Count, i).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i).PasteSpecial xlPasteValues
            End If
    Next i
    End If

Next ws
End Sub

ali mi se pojavljuje problem, kada unesem opseg A1, dakle samo jedna kolona, izbacuje mi gresku run-time error 13 mismatch ,na liniji

Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))

niz Arr je variant, zasto ne prihvata ovu vrednost?

[ gogi100 @ 17.05.2022. 12:00 ] @

stavio sam header jednog sheet-a u niz, koji je pre toga kopiran u novi sheet. svaka kolona tj. header svakog sheet-a se uporedjuje sa headerom iz novog sheeta i ako ima ista vrednost, kopira se kolona. ovako mi nesto treba

[ gogi100 @ 17.05.2022. 19:06 ] @

resio sam problem sa opsegom, ali imam problem kad se radi kopiranje, ukoliko u nekoj koloni imam neko prazno mesto, ono se ne kopira u novi sheet. moj kod je

Code:
Sub MasterMine()

Dim Master As Worksheet
Dim LR1 As Long, LR2 As Long, LC1 As Long, LC2 As Long
Dim ws As Worksheet
Dim Found As Range
Dim i As Long
Dim Arr As Variant
Dim r2 As Variant
Dim pas As Worksheet
Dim headers As Range
Dim SheetExists As Boolean
  'Set Master sheet for consolidation
  Set wb = ActiveWorkbook
  SheetExists = False
  Set pas = ActiveSheet
  For Each ws In ActiveWorkbook.Sheets
  If ws.Name = "AllSheets" Then
  SheetExists = True
  End If
  Next ws

  If SheetExists = False Then

    Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "AllSheets"
    Set Master = ActiveWorkbook.Sheets("AllSheets")
    pas.Activate
    'Get Headers
    Set headers = Application.InputBox("Izaberi opseg Header-a", Type:=8)
    'Copy Headers into master
    headers.Copy Master.Range("A1")
    LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
    If LC1 = 1 Then

        r2 = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
          ReDim Arr(0 To Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Count) ' redim array size to 1 (only 1 cell in range)
        Arr(0) = r2
         'Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value
    Else
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
    End If

    'Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value
  ElseIf SheetExists = True Then

     Set Master = ActiveWorkbook.Sheets("AllSheets")
     pas.Activate
     LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
     If IsEmpty(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value) Then
        MsgBox "Postoji Sheet AllSheets, ali nema imena kolona. Unesite nazive kolona!"
        End
     End If
     If LC1 = 1 Then
          r2 = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
          ReDim Arr(0 To Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Count) ' redim array size to 1 (only 1 cell in range)
        Arr(0) = r2
     Else
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
    End If

  End If

For Each ws In ActiveWorkbook.Sheets
    If ws.Name <> "AllSheets" Then

    For i = LBound(Arr) To UBound(Arr)
        LC2 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
         Set Found = ws.Range(ws.Cells(1, 1), ws.Cells(1, LC2)).Find(Arr(i), LookIn:=xlValues)

            If Not Found Is Nothing Then
             If LC1 = 1 Then
                LR1 = Master.Cells(Master.Rows.Count, i + 1).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i + 1).PasteSpecial xlPasteValues
                    With Master.Columns(1)
                      .EntireColumn.AutoFit
                    End With

                Else
                LR1 = Master.Cells(Master.Rows.Count, i).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i).PasteSpecial xlPasteValues
                    With Master.Columns(i)
                      .EntireColumn.AutoFit
                    End With
                End If

            End If
    Next i
    End If

Next ws
End Sub

ono sto zelim prikazano je u allsheets-1

[ djux66 @ 19.05.2022. 10:49 ] @

Malo sam se igrao sa tvojim prvobitnim kodom, pa testiraj, primer u prilogu.

Code:

Option Explicit

Sub MergeSheets()
On Error GoTo MergeSheets_Error

Dim rowCounter, lastRow, lastCol, colIndex, i As Long
Dim headers As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim pas As Worksheet
Dim mtr As Worksheet
Dim colName As Range
Dim allSheets As String
allSheets = "AllSheets"

'Setup
Set wb = ActiveWorkbook
Set pas = wb.ActiveSheet

'Get Headers
Set headers = Application.InputBox("Izaberi opseg Header-a", Type:=8)

Application.ScreenUpdating = False

If SheetExists(wb, allSheets) Then
    Application.DisplayAlerts = False
    wb.Sheets(allSheets).Delete
    Application.DisplayAlerts = True
End If

wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = allSheets
Set mtr = wb.Sheets(allSheets)

'Copy Headers into master
colIndex = 1
For Each colName In headers
    mtr.Cells(1, colIndex).Value = colName.Value
    colIndex = colIndex + 1
Next

rowCounter = 2
'loop through all sheets
For Each ws In wb.Worksheets

     'except the master sheet from looping
     If (ws.Name <> "AllSheets") Then
        ws.Select
        lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
        lastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

        'get data from each worksheet and copy it into AllSheets sheet
        colIndex = 1
        For Each colName In headers
            For i = 1 To lastCol
                If (ws.Cells(1, i).Value = colName.Value) Then
                    Debug.Print (i)

                    ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i)).Copy
                    mtr.Range(mtr.Cells(rowCounter, colIndex), mtr.Cells(rowCounter + i, colIndex)).PasteSpecial

                    Exit For
                End If
            Next

            colIndex = colIndex + 1
        Next
     End If

    rowCounter = rowCounter - 1 + lastRow

Next ws

Sheets("AllSheets").Activate

Exit_MergeSheets:
    Application.ScreenUpdating = True
    Exit Sub

MergeSheets_Error:
    MsgBox Err.Description, vbExclamation, "MergeSheets Error " & Err.Number
    Resume Exit_MergeSheets

End Sub

Private Function SheetExists(wb As Workbook, sheetToFind As String) As Boolean
    Dim Sheet As Worksheet
    SheetExists = False
    For Each Sheet In wb.Worksheets
        If sheetToFind = Sheet.Name Then
            SheetExists = True
            Exit Function
        End If
    Next Sheet
End Function