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

• #43228 Delila_1 veterán Sesy #43224

  Új Válasz 2020-03-11 13:58:57 #43228

  Ú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 Sesy #43224 üzenetére

  Itt van magyarázatokkal a makró.

  Sub Elrendezes()
Dim sor As Long, usor As Long
Dim WS1 As Worksheet, WS2 As Worksheet

Application.ScreenUpdating = False 'képernyő frissítés leállítása, gyorsabb végrehajtás

Set WS1 = Sheets("Munka1") 'innen kezdve a Sheets("Munka1") helyett elég WS1-et írni
Set WS2 = Sheets("Munka2") 'innen kezdve a Sheets("Munka2") helyett elég WS2-et írni
usor = WS1.Range("A" & Rows.Count).End(xlUp).Row 'alsó sor a Munka1 lapon

For sor = 1 To usor
'az InStr a szöveg.keres VBA-s változata
'ha van a szövegben ":", de nem "Cikkszám:", akkor bontsa ketté a szöveget az A és B oszlopokba
'a mintád 57. sorában
' "BAKONYTHERM 30 N+F belső teherhordó fal, 300x250x240 mm, I.o., Cikkszám:TÉG13 M 2,5 (Hf30-cm) falazó, meszes cementhabarcs"
'szerepel, emiatt kellett a 2. feltételt berakni
If InStr(WS1.Cells(sor, 1), ":") > 0 And InStr(WS1.Cells(sor, 1), "Cikkszám") = 0 Then
WS2.Cells(sor, 1) = Left(WS1.Cells(sor, 1), InStr(WS1.Cells(sor, 1), ":"))
WS2.Cells(sor, 2) = Mid(WS1.Cells(sor, 1), InStr(WS1.Cells(sor, 1), ":") + 1, 70)
Else
WS2.Cells(sor, 1) = WS1.Cells(sor, 1) 'ha nincs ":", akkor a teljes szöveg az A-ba
End If

'formátum másolás Munka1-ről Munka2-re az A és B oszlopban a félkövér sorok miatt
WS1.Cells(sor, 1).Copy
WS2.Range("A" & sor & ":B" & sor).PasteSpecial xlPasteFormats
Next
'csere funkció, a " Ft/m2" és " Ft/óra" cseréje semmire
WS2.Cells.Replace What:=" Ft/m2", Replacement:=""
WS2.Cells.Replace What:=" Ft/óra", Replacement:=""

WS2.Columns("A:A").ColumnWidth = 13.71 'az A oszlop kiszélesítése

Application.ScreenUpdating = True 'képernyő frissítés engedélyezése
End Sub

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