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

• #31790 Delila_1 veterán alevan #31785

  Új Válasz 2016-06-15 17:11:47 #31790

  Ú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 alevan #31785 üzenetére

  Van itt 3 makró.

  Sub Gyujtes()
Dim lap As Integer, usor As Long

Sheets(1).Range("N:Q") = ""

'Címsor az első lapon az N1:Q1-be
Sheets(1).Range("N1:Q1") = Sheets(1).Range("A1:D1").Value

For lap = 1 To Worksheets.Count 'Lapok tartalma az első lapra
usor = Sheets(1).Range("N" & Rows.Count).End(xlUp).Row + 1
Sheets(lap).Range("A1").CurrentRegion.Offset(1).Copy Sheets(1).Range("N" & usor)
Next
Rendez
End Sub

  Sub Rendez()
Dim usor As Long

Sheets(1).Select
usor = Range("N" & Rows.Count).End(xlUp).Row
Range("N1").CurrentRegion.Select
ActiveWorkbook.Sheets(1).Sort.SortFields.Clear
ActiveWorkbook.Sheets(1).Sort.SortFields.Add Key:=Range("N2:N" & usor), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("N1:Q" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Fajlokba usor
End Sub

  Sub Fajlokba(usor)
Dim utvonal As String, elso As Long, ucso As Long, nev As String

utvonal = "D:\Mentés\" '*** Ezt írd át! **************
elso = 2: ucso = 2: nev = Sheets(1).Range("N2")
Do
nev = Sheets(1).Cells(elso, "N")
If nev = "" Then Exit Do
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = nev
Range("A1:D1") = Sheets(1).Range("A1:D1").Value 'Címsor az új füzetbe
ucso = Application.Match(nev, Sheets(1).Columns(14), 1)
Sheets(1).Range("N" & elso & ":Q" & ucso).Copy Sheets(nev).Range("A2")
ActiveSheet.Move
ActiveWorkbook.SaveAs Filename:=utvonal & nev & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

elso = ucso + 1
Loop
Sheets(1).Select
MsgBox "Kész", vbInformation
End Sub

  A harmadikban írt át a csillagokkal jelzett sorban az útvonalat.
  Az első makrót (Gyujtes) kell indítanod, az majd hívja a másik kettőt.
  Az első lap N:Q oszlopába összegyűjti a többi lap adatait, rendezi a nevek szerint, majd új lapra másolja egyenként a nevekhez tartozó sorokat. Ezt az új lapot áthelyezi egy új fájlba, és menti a megadott névvel, majd be is zárja.

• #31786 DeFranco nagyúr alevan #31785

  Új Válasz 2016-06-15 14:05:07 #31786

  Ú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

  

  DeFranco

  nagyúr

  válasz alevan #31785 üzenetére

  hát ide valami ipari megoldás kell... én ehhez kevés vagyok.

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