Kopiranje stolpcev po imenu na drug list

[drglzr]

Pozdravljeni.

Priložen makro (najden na internetu in prirejen) iz določenega območja na "Listu4" zajema podatke o naslovih (imenih) stolpcev, ki jih išče v naslovni vrstici "Lista2". Ko najde enak naslov stolpca, celoten stolpec kopira na "List3". Zadeva deluje, vendar kopira le prvi najden stolpec, čeprav jih je na "Listu2" več z enakim imenom. Želel bi, da pregleda celotno naslovno vrstico (dokler so v njej podatki), prekopira vse stolpce z enakim imenom (ki bi jih nato obdelal z dodatno vstavljenim makrojem) in gre šele nato iskati in kopirati stolpce z naslednjim imenom. Tu pa se zatakne.

Makro sem poskušal prirediti z While – Wend funkcijo, pa z Do – Loop While, vendar mi nikakor ne uspe doseči želenega. Čeprav sem prepričan, da bi z eno od teh funkcij moral doseči želeno, te ne znam na pravilen način postaviti na pravo mesto. Ali se motim? Ne vem, kje je zanka.

Hvaležen bi bil za nasvet.

Lep pozdrav,

Drago

Koda: Izberi vse

Sub CopyColsMOJ()

    Dim h As Range, f As Range, sht1, rngDest As Range

    Set sht1 = ThisWorkbook.Sheets("List2")
    Set rngDest = ThisWorkbook.Sheets("List3").Range("C1") 'start pasting here
    
    'loop through the headers to copy
    For Each h In ThisWorkbook.Sheets("List4").Range("F1:Q1").Cells
        'find the header on List2 OD TU NAPREJ SE MORA PONAVLJATI DO KONCA VRSTICE NA LISTU2
        Set f = sht1.Rows(1).Find(h.Value, , xlValues, xlWhole)

        If Not f Is Nothing Then
            'found the header: copy the column
            f.EntireColumn.Copy rngDest
            Set rngDest = rngDest.Offset(0, 1) ' move destination
        
        End If
        Set f = Nothing
'TU PRIDE MAKRO ZA OBDELAVO PODATKOV
    Next h

End Sub

[admin]

Pozdravljeni,

Kar neka zanka vam ne bo pomagala. Težavo vam povzroča funkcija FIND, ki pač najde prvi zadetek in tudi v zanki vedno najde prvi zadetek. Precej lažji in smiselnejši je postopek, kjer se v zanki sprehodite skozi naslove lista 2 in jih enega po enega primerjate z naslovom iz lista 4. No to sem vam zapisal jaz:

Koda: Izberi vse

Sub CopyColsMOJ()

    Dim h As Range, f As Range, sht1, rngDest As Range

    Set sht1 = ThisWorkbook.Sheets("List2")
    Set rngDest = ThisWorkbook.Sheets("List3").Range("C1") 'start pasting here
    
    Dim c As Integer
    'loop through the headers to copy
    For Each h In ThisWorkbook.Sheets("List4").Range("F1:Q1").Cells
        c = 1
        While Trim(sht1.Cells(1, c)) <> ""
          If (Trim(sht1.Cells(1, c)) = Trim(h.Value)) Then
            'found the header: copy the column
            sht1.Cells(1, c).EntireColumn.Copy rngDest
            Set rngDest = rngDest.Offset(0, 1) ' move destination
          End If
        
          c = c + 1
        Wend

'TU PRIDE MAKRO ZA OBDELAVO PODATKOV
    Next h

End Sub

[drglzr]

Pozdravljeni.

Najlepša hvala za pomoč.

O funkciji FIND sem razmišljal in poskušal z uvedbo FindNext, vendar tudi s tem nisem dosegel želenega rezultata. Na "TRIM" pa zagotovo ne bi niti pomislil. Kljub vsemu sem v tem še zelo zelen.

Koda, ki ste jo zapisali deluje, kot sem želel. Nekaj težav mi je povzročala pri rngDest.Offset(0, 1), ko je stolpce z naslednjim imenom začela lepiti, kjer se je prejšnje lepljenje končalo, četudi sem prej prilepljene stolpce izbrisal in izbral (Range.Select) ali aktiviral (Range.Activate) celico "C1". Zadevo sem rešil s ponovitvijo vrstice

Koda: Izberi vse

Set rngDest = ThisWorkbook.Sheets("List3").Range("C1")

za ukazom "Wend". Verjetno obstaja elegantnejša rešitev, vendar meni deluje tudi ta. Moj končni zapis je spodaj.

Lep pozdrav.

Drago

Koda: Izberi vse

Sub CopyColsMOJ()

    Dim h As Range, sht1, rngDest As Range

    Set sht1 = ThisWorkbook.Sheets("List2")
    Set rngDest = ThisWorkbook.Sheets("List3").Range("C1") 'start pasting here
    
    Dim c As Integer
    'loop through the headers to copy
    For Each h In ThisWorkbook.Sheets("List4").Range("F1:Q1").Cells
        c = 3
        While Trim(sht1.Cells(1, c)) <> ""
          If (Trim(sht1.Cells(1, c)) = Trim(h.Value)) Then
            'found the header: copy the column
            sht1.Cells(1, c).EntireColumn.Copy rngDest
            Set rngDest = rngDest.Offset(0, 1) ' move destination
          End If
        
          c = c + 1
        Wend
    
    Set rngDest = ws1.Range("C1") 'restart pasting here another h.Value

'TU (ALI ZA WEND) PRIDE MAKRO ZA OBDELAVO PODATKOV    
    Next h

End Sub