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

• #35719 Fferi50 Topikgazda Acustic #35716

  Új Válasz 2017-07-13 12:48:56 #35719

  Ú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

  

  Fferi50

  Topikgazda

  válasz Acustic #35716 üzenetére

  Szia!

  Az alábbi makrókat bemásolod egy modulba. Majd hozzárendelheted az általad kívánt billentyű kombinációhoz:
  Public frm As CellFormat
Sub névminta()
'
' névminta Makró
' ctrl+n a neveket előbb besárgítja, majd kereső funkcióra áll, megtalálja az első nevet.
'
' Billentyűparancs: Ctrl+n
'
'Dim frm As CellFormat
Dim frm1 As Range, frm2 As Range
If frm Is Nothing Then Set frm = Application.ReplaceFormat
Set frm1 = Range("I1")
Set frm2 = Range("I2")
frm.Clear
With frm 'Application.ReplaceFormat
.HorizontalAlignment = frm1.HorizontalAlignment 'xlRight
.VerticalAlignment = frm1.VerticalAlignment ' xlTop
With .Font
.Name = frm1.Font.Name ' "Arial"
.FontStyle = frm1.Font.FontStyle ' "Normál"
.Size = frm1.Font.Size ' 12
.Color = frm1.Font.Color ' vbBlack
End With
.Borders.LineStyle = xlNone
With .Interior
.PatternColorIndex = frm1.Interior.PatternColorIndex ' xlAutomatic
.Color = frm1.Interior.Color ' 65535
End With
.Locked = True
.FormulaHidden = False
End With
Columns("A:A").Replace what:=Range("H1").Value, replacement:=Range("H1").Value, LookAt:=xlWhole, _
searchorder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=True
Application.EnableEvents = False
Cells.Find(what:=Range("H1").Value, LookIn:=xlFormulas, LookAt _
:=xlWhole, searchorder:=xlByColumns, MatchCase _
:=False, SearchFormat:=False).Activate
With frm 'Application.ReplaceFormat
.HorizontalAlignment = frm2.HorizontalAlignment ' xlLeft
.VerticalAlignment = frm2.VerticalAlignment ' xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
With .Font
.Name = frm2.Font.Name ' "Arial"
.FontStyle = frm2.Font.FontStyle ' "Normál"
.Size = frm2.Font.Size ' 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.Color = -16776961
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End With
Application.EnableEvents = True
End Sub
Sub nevpiros()
'A H1 cellában levő nevet az A oszlopban "bepirosítja"
Dim frm1 As Range, frm2 As Range
If frm Is Nothing Then Set frm = Application.ReplaceFormat
Set frm1 = Range("I1")
Set frm2 = Range("I2")
With frm 'Application.ReplaceFormat
.HorizontalAlignment = frm2.HorizontalAlignment ' xlLeft
.VerticalAlignment = frm2.VerticalAlignment ' xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
With .Font
.Name = frm2.Font.Name ' "Arial"
.FontStyle = frm2.Font.FontStyle ' "Normál"
.Size = frm2.Font.Size ' 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.Color = -16776961
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End With
Range("A:A").Replace what:=Range("H1").Value, replacement:=Range("H1").Value, ReplaceFormat:=True
End Sub

  A billentyű hozzárendelést neked kell megtenni.
  Az első sor is fontos, ami a sub előtt van. Itt definiálunk egy olyan változót, amelynek az értéke megmarad mindaddig, amíg ki nem léptél az excelből.

  Ha még jobban automatizálni szeretnéd, akkor a következő két makrót a munkalap kódlapjára kell bemásolnod: (jobb egérgomb a munkalap fülön, kód megjelenítése)
  Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 And Target.Row = 1 Then 'ha új nevet írsz a H1 cellába
Application.EnableEvents = False
névminta
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cl As Range
If Target.Column = 1 Then 'ha a H1 cellában levő névre léptél, az előzőt "bepirosítja"
If Target.Value = Range("H1").Value Then
If Target.Row > 1 Then
Application.EnableEvents = False
Set cl = Columns("A:A").Find(what:=Target.Value, after:=Target, searchdirection:=xlPrevious)
If Not cl Is Nothing Then cl.Replace what:=Target.Value, replacement:=Target.Value, ReplaceFormat:=True
Application.EnableEvents = True
End If
End If
End If
If Target.Column = 8 And Target.Row = 1 Then ' az utolsó nevet is elérted, ezért a H1 cellára ugrottál - az utolsó nevet is megváltoztatja
Set cl = Columns("A:A").Find(what:=Target.Value, after:=Columns("A:A").End(xlUp), searchdirection:=xlPrevious)
If Not cl Is Nothing Then cl.Replace what:=Target.Value, replacement:=Target.Value, ReplaceFormat:=True
End If
End Sub

  Az első akkor lép működésbe, ha a H1 cellába beírsz egy nevet. Ekkor automatikusan megjelöli az A oszlopban mindazokat a cellákat, amelyben az a név van.

  A második azt figyeli, hogy az új cellában, amire léptél, a H1 -ben levő név van-e. Ha igen, akkor az előző nevet megváltoztatja (pirosítja).
  Ugyanígy jár el az utolsó névvel, ha a H1 cellára ugrasz.
  Nem kell azonnal a következő névre (H1 cellára) ugrani, amikor a lefelé "sétálásban" ugyanarra a névre lépsz, akkor lép működésbe.

  Remélem érthető, ha nem, akkor kérdezz bátran.

  Üdv.

• #35718 Fferi50 Topikgazda Acustic #35716

  Új Válasz 2017-07-13 08:55:58 #35718

  Ú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

  

  Fferi50

  Topikgazda

  válasz Acustic #35716 üzenetére

  Szia!

  Ez jó irány. A replace metódus what paramétere helyére ne konkrét nevet írj, hanem annak a cellának az értékére hivatkozz, amiben a név van:
  What:=Range("H1").Value, Replacement:=Range("H1").Value
  Viszont a makrórögzítés egy csomó felesleges dolgot is beletesz.
  Ennél sokkal rövidebb lehet.
  Szerintem 2 makró kell, az egyik sárgít, a másik kiszedi a sárgát és pirosra váltja.
  Kicsit később még visszajövök egy megoldás tervezettel.

  Üdv.

• #35717 Delila_1 veterán Acustic #35716

  Új Válasz 2017-07-13 07:09:06 #35717

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

  Ha jól értem, a H oszlopba írod be az aktuális szereplő nevét. Ekkor az A oszlopban lévő, ilyen nevű szereplőt tartalmazó cellák váljanak sárga hátterűvé, felül jobbra rendezetté. Mikor új nevet adsz meg a H oszlopban, az előbbi cellák legyenek piros hátterűek, felül balra rendezettek, és az újonnan megadott név cellái sárgák, felül jobbra rendezettek.

  A laphoz rendeld a makrót (lásd a téma összefoglalóban).

  Private Sub Worksheet_Change(ByVal Target As Range)
Dim ter As Range, CV As Object
If Target.Column = 8 Then
Set ter = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
For Each CV In ter
If CV.Interior.Color = vbYellow Then
CV.Interior.Color = vbRed
CV.HorizontalAlignment = xlLeft
CV.VerticalAlignment = xlTop
End If
If CV = Target Then
CV.Interior.Color = vbYellow
CV.HorizontalAlignment = xlRight
CV.VerticalAlignment = xlTop
End If
Next
End If
End Sub

  Remélem, így gondoltad. Ha nem, akkor vagy segít valaki, vagy délután én átírom a makrót.

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