Oszlopok másolása kritériumok szerint excel

Oszlopok másolása kritériumok szerint excel
2022-01-20T12:16:52+01:00
2022-01-20T14:50:43+01:00
2022-10-15T21:20:49+02:00
Pilu88
Sziasztok,

Adatokat szeretnék átmásolni az "A" táblából a "B" táblába.

A "B" tábla Fix fejléccel rendelkezik. A1: Név, B1: Hely, C1: Dátum

Az "A" tábla fejléce változik, illetve nem minden esetben a legelső sor tartalmazza és az oszlopok megnevezése is változik.

Létrehoztam egy "C" táblát amibe felvezettem a "B" tábla fejlécét és, hogy milyen egyéb megnevezései lehetnek. PL: A1: Név,                   B1: Hely,            C1: Dátum
                                            A2: Megnevezés       B2: Location,     C1:  Sz.Dátum
                                            A3: Sz. Név,               B3: T.Hely          C1: Date
                                            A4: Name,                                           C1: Dátum/Idő

Az "A" táblában szereplő adatot szereplő adatot szeretném a "B" táblába másolni, a kritériumok alapján. Ha az "A" tábla valamelyik mezője egyezik a "C" tábla valamelyik mezőjével akkor az egyezés alatt található összes adatot abból az oszlopból másolja át a B tábla azon oszlopába ahol a fejléc megegyezik a C tábla fejlécével . 
A következővel próbálkoztam, viszont ez csak az első sorokat tudja átnézni és egyesével kell beirkálni a kritériumokat.

A segítséget előre is köszönöm

Public Sub Copyby() Dim sourceWS As Worksheet, targetWS As Worksheet Dim lastCol As Long, lastRow As Long, srcRow As Range Dim found1 As Range, found2 As Range Set sourceWS = Worksheets("Sheet A") Set targetWS = Worksheets("Sheet B") With sourceWS lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column Set srcRow = .Range("A1", .Cells(1, lastCol)) Set found1 = srcRow.Find(What:="Név", LookAt:=xlWhole, MatchCase:=False) If Not found1 Is Nothing Then lastCol = targetWS.Cells(1, Columns.Count).End(xlToLeft).Column Set srcRow = targetWS.Range("A1", targetWS.Cells(1, lastCol)) Set found2 = srcRow.Find(What:="Név", LookAt:=xlWhole, MatchCase:=False) If Not found2 Is Nothing Then lastRow = .Cells(Rows.Count, found1.Column).End(xlUp).Row .Range(.Cells(2, found1.Column), .Cells(lastRow, found1.Column)).Copy found2.Offset(1, 0).PasteSpecial xlPasteAll End If End If End With End Sub
Mutasd a teljes hozzászólást!
Szia!

Ha így szeretnéd megoldani, akkor a FindNext lesz a barátod

leírás és példaprogram:

Range.FindNext method (Excel)
Mutasd a teljes hozzászólást!

Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd