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

• #37540 Delila_1 veterán tgumis #37537

  Új Válasz 2018-03-18 08:00:39 #37540

  Ú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

  

  Delila_1

  veterán

  válasz tgumis #37537 üzenetére

  A makró elejére beírtam a kérdést, a vége felé meg ott van a képletek másolása.

  Sub Szur_Masol_Torol()
Dim usor As Long, WSBev As Worksheet, WSOsz As Worksheet
Dim Bsor As Long, Csor As Long, valasz

valasz = MsgBox("Áttölthetem az adatokat?", vbYesNo + vbQuestion, "Választás")
If valasz = vbNo Then Exit Sub

'lapok védelmének feloldása a makró számára
WSBev.Protect Password:="pw", UserInterfaceOnly:=True
WSOsz.Protect Password:="pw", UserInterfaceOnly:=True

'értékadások
Set WSBev = Sheets("bevitel")
Set WSOsz = Sheets("ÖSSZESÍTÉS")
Bsor = WSOsz.Range("B" & Rows.Count).End(xlUp).Row + 1
usor = WSBev.Range("D2").End(xlDown).Row

'szűrés OK-ra
WSBev.ListObjects("bevitel").Range.AutoFilter Field:=17, Criteria1:="=OK"

'másolás és érték beillesztés
WSBev.Range("D2:T" & usor).Copy
WSOsz.Range("C" & Bsor).PasteSpecial xlPasteValues

'képlet, majd érték beillesztés a B oszlopba
Csor = WSOsz.Range("C" & Rows.Count).End(xlUp).Row
WSOsz.Range("B" & Bsor & ":B" & Csor) = "=B" & Bsor - 1 & "+1"
WSOsz.Columns(2).Copy
WSOsz.Range("B1").PasteSpecial xlPasteValues

'T2:W2 képlete az új sorokba az Összesítés lapon
WSOsz.Range("T2:W2").Copy
WSOsz.Range("T" & Bsor & ":W" & Csor).PasteSpecial xlPasteFormulas
Application.CutCopyMode = False 'kijelölés megszüntetése

With WSOsz.Range("B1").CurrentRegion 'keretezés
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With

WSBev.ListObjects("bevitel").Range.AutoFilter Field:=17 'OK-ra szűrés megszüntetése
WSBev.Range("D2:E200,G2:G200,H2:I200,B1:B6").ClearContents 'törlés

'új jelszó a bevitel laphoz
WSBev.Protect Password:="LiliLufi140127", UserInterfaceOnly:=True, _
AllowFiltering:=True, AllowFormattingColumns:=True
End Sub

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