Új hozzászólás Aktív témák

• #39448 Mutt senior tag wednesday #39417

  Új Válasz 2018-10-24 11:58:10 #39448

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz wednesday #39417 üzenetére

  Szia,

  Itt van mutatott mintához a makró. A kommentek alapján tudod finomítani.

  Sub Mentes()
Const urlap_helye = "Urlap" 'munkalap neve ahol van az űrlap
Const mentes_helye = "Mentes" 'munkalap neve ahova menteni kellene

Dim utolsoSor As Long, i As Long
Dim wsForras As Worksheet
Dim wsMentes As Worksheet

Set wsForras = ThisWorkbook.Sheets(urlap_helye)
Set wsMentes = ThisWorkbook.Sheets(mentes_helye)

With wsMentes
utolsoSor = .Range("A" & Rows.Count).End(xlUp).Row + 1 'megkeressük az első szabadsort a mentés lapon

For i = 17 To 35 'az űrlap 17-35 sora között nézzük a felírásokat
If Len(.Cells(i, "C")) > 0 Then
.Cells(utolsoSor, "A") = Now 'A-oszlopba rögzíjük a mentés dátumát
.Cells(utolsoSor, "B") = wsForras.Range("D7") 'B-oszlopba jön az első sorban lévő D-L egyesített cella tartalma
.Cells(utolsoSor, "C") = wsForras.Range("B" & i) 'C-oszlopba jön a B-oszlopbeli sorszám
.Cells(utolsoSor, "D") = wsForras.Range("C" & i) 'D-oszlopba a C-H tartalma
.Cells(utolsoSor, "E") = wsForras.Range("J" & i) 'E-oszlopba a J tartalma
.Cells(utolsoSor, "F") = wsForras.Range("K" & i) 'F-oszlopba a K tartalma

If .Cells(i, "C").MergeCells Then 'ha összevont cellákról van szó, akkor át kell ugornunk az összevont sorokat
i = i + .Cells(i, "C").MergeArea.Rows.Count - 1
End If
utolsoSor = utolsoSor + 1
End If
Next i

End With

Set wsForras = Nothing
Set wsMentes = Nothing

End Sub

  üdv

Új hozzászólás Aktív témák