Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.

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

[es] :: Office :: Excel :: kopiranje kolona sa istim header-om iz vise sheet-ova u novi

[ Pregleda: 739 | Odgovora: 7 ] > FB > Twit

Postavi temu Odgovori

Autor

Pretraga teme: Traži
Markiranje Štampanje RSS

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.dynamic.isp.telekom.rs.



+3 Profil

icon kopiranje kolona sa istim header-om iz vise sheet-ova u novi16.05.2022. u 08:46 - pre 22 meseci
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
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
*.dynamic.isp.telekom.rs.

Sajt: www.gowi.rs


+109 Profil

icon Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi16.05.2022. u 14:41 - pre 22 meseci
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
Nije to loše Rembrante, samo što ne bi dodao još malo boje?
 
Odgovor na temu

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.dynamic.isp.telekom.rs.



+3 Profil

icon Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi16.05.2022. u 16:26 - pre 22 meseci
meni treba makro u excel-u. da li se to moze uraditi?
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
89.216.49.*

Sajt: www.gowi.rs


+109 Profil

icon Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi17.05.2022. u 09:08 - pre 22 meseci
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

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

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.dynamic.isp.telekom.rs.



+3 Profil

icon Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi17.05.2022. u 11:57 - pre 22 meseci
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?
 
Odgovor na temu

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.dynamic.isp.telekom.rs.



+3 Profil

icon Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi17.05.2022. u 12:00 - pre 22 meseci
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
 
Odgovor na temu

gogi100
Goran Ljubic

Član broj: 40722
Poruke: 1064
*.dynamic.isp.telekom.rs.



+3 Profil

icon Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi17.05.2022. u 19:06 - pre 22 meseci
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
Prikačeni fajlovi
 
Odgovor na temu

djux66
Beograd

Član broj: 66577
Poruke: 74
*.amres.ac.rs.

Sajt: www.mmveriga.co.rs


+9 Profil

icon Re: kopiranje kolona sa istim header-om iz vise sheet-ova u novi19.05.2022. u 10:49 - pre 22 meseci
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



Prikačeni fajlovi
 
Odgovor na temu

[es] :: Office :: Excel :: kopiranje kolona sa istim header-om iz vise sheet-ova u novi

[ Pregleda: 739 | Odgovora: 7 ] > FB > Twit

Postavi temu Odgovori

Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.