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

• #35721 Delila_1 veterán Acustic #35720

  Új Válasz 2017-07-14 07:39:45 #35721

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

  Szia Attila!

  Az első makrót a laphoz kell rendelned. Mikor a H oszlopba beírsz, vagy bemásolsz egy nevet, akkor ez a cella, valamint az A oszlopban lévő, azonos tartalmú cellák háttere sárga lesz. Az első, A oszlopban lévő név cellája lesz kijelölt.

  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 = Target Then
CV.Interior.Color = vbYellow
CV.HorizontalAlignment = xlRight
CV.VerticalAlignment = xlTop
End If
Next
Range(Target.Address).Interior.Color = vbYellow
Range(Target.Address).HorizontalAlignment = xlRight
Range(Target.Address).VerticalAlignment = xlTop
Range("A" & Application.WorksheetFunction.Match(Target, Columns(1), 0)).Select
End If
End Sub

  A második makró modulba kerül. Ehhez rendelj billentyű kombinációt, aminek hatására indul a makró. Az aktuális cella háttere piros lesz, a kijelölés a következő, ilyen nevet tartalmazó cellára ugrik az A oszlopban. Mikor a kombinációval befejezted a szereplőhöz tartozó összes cella átszínezését, a H oszlopban is pirosra vált a név cellája, ez lesz kijelölt. Üzenetet kapsz, hogy a szereplő összes sora kész van.

  Sub Piros()
Dim sor, nev As String

If Selection.Column = 1 Then
nev = Selection.Value
On Error GoTo KeszVan
sor = Range("A" & Selection.Row + 1 & ":A10000").Find(nev).Row
Selection.Interior.Color = vbRed
Selection.HorizontalAlignment = xlLeft
Cells(sor, "A").Select
End If
Exit Sub

KeszVan:
Selection.Interior.Color = vbRed
Selection.HorizontalAlignment = xlLeft
sor = Columns(8).Find(nev).Row
Cells(sor, "H").Interior.Color = vbRed
Cells(sor, "H").HorizontalAlignment = xlLeft
Cells(sor, "H").Select

MsgBox nev & " minden sora kész van.", vbInformation, "Értesítés"
End Sub

  Jó munkát! Üdv
  Kati

• #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.

• #35715 Fferi50 Topikgazda Acustic #35714

  Új Válasz 2017-07-12 11:21:24 #35715

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

  Szia!

  Megmutatnád, hogy milyen makrót sikerült összehoznod? Nagyjából érthető, amit leírtál, de könnyebb lenne segíteni, ha lenne valamilyen minta.
  Egy kérdés pl. hogy honnan tudja a makró, hogy melyik nevet szeretnéd "elültetni"?

  Üdv.

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