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

• #16628 Delila_1 veterán Attas #16625

  Új Válasz 2013-02-08 13:01:25 #16628

  Ú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 Attas #16625 üzenetére

  Munka1 lapnak nevezem azt, amelyiken az eredeti adataid vannak, Munka2-nek azt, amelyikre másolok.
  A Munka1 Y1, Z1, és AA1 celláiba írom be (vagy választom ki érvényesítés segítségével) a 3 adatot.
  A Munka2 lapra előre átmásoltam a címsort.

  Sub Makro()
  Dim sor As Integer, usor As Integer, sor1 As Integer
  Dim WS1 As Worksheet, WS2 As Worksheet
  Dim a$, b$, c$
  Set WS1 = Sheets("Munka1") 'Itt változtathatsz
  Set WS2 = Sheets("Munka2") 'Itt változtathatsz
  usor = WS1.Cells(Rows.Count, "A").End(xlUp).Row
  sor1 = 2
  a$ = WS1.Range("Y1")
  b$ = WS1.Range("Z1")
  c$ = WS1.Range("AA1")
  
  'Előző adatok törlése a Munka2 lapon
  WS2.Rows("2:5000").Delete shift:=xlUp
  
  For sor = 2 To usor
  If WS1.Cells(sor, "U") = a$ And WS1.Cells(sor, "V") = b$ And _
  WS1.Cells(sor, "W") = c$ Then
  Rows(sor).Copy WS2.Cells(sor1, "A")
  sor1 = sor1 + 1
  End If
  Next
  End Sub

  Közben befutott egy másik megoldás is, de ha már megírtam, elküldöm.

• #16627 Excelbarat tag Attas #16625

  Új Válasz 2013-02-08 12:58:45 #16627

  Ú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

  

  Excelbarat

  tag

  válasz Attas #16625 üzenetére

  Hi itt egy:

  Sub kereso()
  Dim acts, lapnev, ufelt, vfelt, wfelt As String
  Dim lastRow As Long
  
  acts = ActiveSheet.Name
  lapnev = InputBox("Mi legyen az új munkalap neve?", "Lapnév")
  Sheets.Add After:=Sheets(Sheets.Count)
  ActiveSheet.Name = lapnev
  
  ufelt = InputBox("U oszlop feltétele:", "Feltételmegadás")
  vfelt = InputBox("V oszlop feltétele:", "Feltételmegadás")
  wfelt = InputBox("W oszlop feltétele:", "Feltételmegadás")
  
  Sheets(acts).Select
  i = 1
  Do Until Cells(i, 21).Value = ""
  
  If Cells(i, 21).Value = ufelt And Cells(i, 22).Value = vfelt And Cells(i, 23).Value = wfelt Then
  Range(Cells(i, 1), Cells(i, 23)).Copy
  Sheets(lapnev).Select
  If Range("A1") = "" Then
  Range("A1").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Else
  lastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
  Cells(lastRow, 1).Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  End If
  
  Sheets(acts).Select
  End If
  i = i + 1
  Loop
  Sheets(lapnev).Select
  Range("A1").Select
  Application.CutCopyMode = False
  End Sub

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