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

• #20187 Delila_1 veterán Attas #20184

  Új Válasz 2014-01-22 10:44:16 #20187

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

  Azt nem írtad, hogy ha a B oszlopból választasz kigyűjtendő adatot, hova írja. Úgy írtam meg a makrót, hogy B választáskor a Munka2, C-nél pedig a Munka1 lapra gyűjtsön ki.
  Az adatokat az Adatok lap tartalmazza. Ezt kell átírnod a makróban 2 helyen a saját lapod nevére.

  Sub Atmasol()
  Dim WS As Worksheet, sor As Long, usor As Long, v$, WF As WorksheetFunction
  Dim oszlop As Integer, sor1 As Long, f As Boolean
  
  Application.ScreenUpdating = False
  
  Set WF = Application.WorksheetFunction
  Sheets("Adatok").Activate
  
  v$ = Application.InputBox("B, vagy C oszlop szerint akarsz másolni?", "Oszlop választás", , , , , , 2)
  If v$ = "B" Or v$ = "b" Then
  Set WS = Sheets("Munka2")
  oszlop = 2
  v$ = Application.InputBox("Kérem a keresendő B értéket", "Adat választás", , , , , , 2)
  GoTo Keres
  End If
  
  If v$ = "C" Or v$ = "c" Then
  Set WS = Sheets("Munka1")
  oszlop = 3
  v$ = Application.InputBox("Kérem a keresendő C értéket", "Adat választás", , , , , , 2)
  GoTo Keres
  End If
  
  MsgBox "B vagy C értéket írhatsz", vbOKOnly + vbExclamation
  Exit Sub
  
  Keres:
  usor = WF.CountA(Columns(oszlop))
  f = False
  For sor = 1 To usor
  If Cells(sor, oszlop) = v$ Then
  If WS.Range("C6") = "" Then sor1 = 6 Else sor1 = WS.Range("C" & Rows.Count).End(xlUp).Row + 1
  Cells(sor, "D").Copy WS.Cells(sor1, "C")
  f = True
  End If
  Next
  
  'Rendezés
  WS.Activate
  Range("C6").Select
  Range(Selection, Selection.End(xlDown)).Select
  Application.CutCopyMode = False
  Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal
  
  Sheets("Adatok").Activate
  Application.ScreenUpdating = True
  
  If f = False Then MsgBox "Nincs a tartományban " & v$ & " érték", vbOKOnly
  End Sub

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