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

kopiranje kolona sa istim header-om iz vise sheet-ova u novi 16.05.2022. u 09:46 · pre 54 meseca #1

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

Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi 16.05.2022. u 15:41 · pre 54 meseca #2

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

Potpis

Nije to loše Rembrante, samo što ne bi dodao još malo boje?

Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi 16.05.2022. u 17:26 · pre 54 meseca #3

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

Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi 17.05.2022. u 10:08 · pre 54 meseca #4

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

Potpis

Nije to loše Rembrante, samo što ne bi dodao još malo boje?

Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi 17.05.2022. u 12:57 · pre 54 meseca #5

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?

Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi 17.05.2022. u 13:00 · pre 54 meseca #6

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

Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi 17.05.2022. u 20:06 · pre 54 meseca #7

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

sheet1.jpg20.88k sheet2.jpg23.8k allsheets.jpg25.17k allsheets-1.jpg24.31k

Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi 19.05.2022. u 11:49 · pre 54 meseca #8

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

Potpis

Lanci, Kuke, Spojnice, Priveznice, Skopci, Hvataljke, Celicna uzad, Valjkasti lanci, Galovi Lanci MM Veriga d.o.o.
Agrorade atomizeri

copy-columns.xlsm24.83k

Forum kao aplikacija na telefonu

Srodne teme