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

• #13668 Delila_1 Topikgazda Bocimaster #13667

  Új Válasz 2012-05-09 06:46:49 #13668

  Ú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

  Topikgazda

  válasz Bocimaster #13667 üzenetére

  A napokban írtam valakinek erre a feladatra egy makrót. Nála az azonosító, ami Nálad a telephely, az A oszlopban van.

  A makró telephelyenként szétdobja külön lapokra a Munka1 lap adatait, majd minden lapot áttesz külön füzetbe, és a telephely nevén lementi. Írtam bele megjegyzéseket, aszerint módosíts a makrón.

  Sub Telephelyek()
  Dim sor As Double, usor As Double, usor_1 As Double, nev$, WS1 As Worksheet
  Dim utvonal$, lap%
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  utvonal = "E:\Eadat\" 'itt írd be a saját útvonaladat ehelyett, ügyelj a \ jelekre
  usor = Cells(Rows.Count, "A").End(xlUp).Row
  Set WS1 = Sheets("Munka1") 'ide jön a saját indító lap%od neve
  
  'Másolás lap%okra
  For sor = 2 To usor
  nev$ = WS1.Cells(sor, 1)
  On Error GoTo Uj_lap
  usor_1 = Sheets(nev$).Cells(Rows.Count, "A").End(xlUp).Row + 1
  
  'a következő 2 sorban írd át a "K"-t az utolsó oszlopod azonosítójára
  If usor_1 = 2 Then Range(WS1.Cells(1, "A"), WS1.Cells(1, "K")).Copy Sheets(nev$).Cells(1)
  Range(WS1.Cells(sor, "A"), WS1.Cells(sor, "K")).Copy Sheets(nev$).Cells(usor_1, "A")
  Next
  
  '**********************************************************************************************
  'Ha nem kell külön füzetekbe menteni a lapokat, ezt a részt hagyd ki
  'Mentés, zárás
  For lap% = 1 To Sheets.Count - 1
  nev$ = utvonal & Sheets(1).Cells(2, "A")
  Sheets(1).Move
  
  ActiveWorkbook.SaveAs Filename:=nev$, FileFormat:=xlNormal _
  , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
  CreateBackup:=False
  ActiveWindow.Close
  Next
  '**********************************************************************************************
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "Kész"
  Exit Sub
  
  Uj_lap:
  If Err = 9 Then
  Worksheets.Add.Name = nev$
  Resume 0
  Else
  Error Err
  End If
  
  End Sub

  Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

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