Excel makro - prohození hodnot dvou buněk+vlození puvodních Vyřešeno

[birgis]

Ahoj,
prosím excel-machry o pomoc s makrem.
Makro by mělo umět u dvou označených buněk (vždy na jiném řádku) ke každé buňce vložit komentář (případně k existujícímu komentáři přidat) hodnotu buňky (text) a text ze sloupce A u druhé označené buňky a k tomu aktuální datum změny(vložení komentáře), a potom hodnoty označených buněk prohodit.

Výsledek by měl vypadat jako v příloze
Děkuju všem za pomoc

Vymena.xlsx

(10.52 KiB) Staženo 96 x

Budu rad i za částečnou pomoc (prohození buněk, nebo jen zápis hodnot do komentáře při změně,...))

[Reklama]

[pavel.lasak]

Zda je označeno tento kód:

Kód: Vybrat vše

Dim Bunka As Range

For Each Bunka In Selection
     
    MsgBox "Vybraný řádek je " & Bunka.Row
    MsgBox "Vybraný sloupec je " & Bunka.Column
    'uloz do promene:  pokus = c.Row
   
Next c


pak použít další kódy na přečtení, zápis http://office.lasakovi.com/excel/vba-li ... excel-vba/

[cmuch]

Ja na to vytvořil makro, trochu delší , ale zdá se funkční.
Buňky musí být vybrané pouze 2 a to přes ctrl, pokud tažením myši tak se to neprovede.

Kód: Vybrat vše

Sub ProhozeniKomentaru()

Dim Adresy, Adresa1, Adresa2 As Variant
Dim Coment1, Coment2 As String

  Adresy = Selection.Address
 
  If InStr(1, Adresy, ":", 1) = 0 And Selection.Count = 2 Then
    Adresa1 = Mid(Adresy, 1, InStr(1, Adresy, ",", 1) - 1)
    Adresa2 = Mid(Adresy, InStr(1, Adresy, ",", 1) + 1, Len(Adresy) - InStr(1, Adresy, ",", 1))
   
    If Range(Adresa1).Comment Is Nothing Then
      Range(Adresa1).AddComment
      Range(Adresa1).Comment.Text Text:="Owner:" & Chr(10) & Range(Adresa1).Value & " " & Cells(Range(Adresa1).Row, "A")
     Else
      Range(Adresa1).Comment.Text Text:="Owner:" & Chr(10) & Range(Adresa1).Value & " " & Cells(Range(Adresa1).Row, "A")
    End If
    If Range(Adresa2).Comment Is Nothing Then
      Range(Adresa2).AddComment
      Range(Adresa2).Comment.Text Text:="Owner:" & Chr(10) & Range(Adresa2).Value & " " & Cells(Range(Adresa2).Row, "A")
     Else
      Range(Adresa2).Comment.Text Text:="Owner:" & Chr(10) & Range(Adresa2).Value & " " & Cells(Range(Adresa2).Row, "A")
    End If
   
    Coment1 = Range(Adresa1).Comment.Text
    Coment2 = Range(Adresa2).Comment.Text
       
    Range(Adresa1).Comment.Text Text:=Coment2
    Range(Adresa2).Comment.Text Text:=Coment1
  End If
End Sub


[birgis]

Ahoj,
já vím, že s budu vymýšlet moc, ale risknu,to:)
Po stisknutá klávesové zkratky by to mělo udělat několik kroků:
1: Načíst hodnoty z označení buněk
2: Ty hodnoty vložit do komentáře u stejné buňky (pokud už existuje u některé z vybraných komentář, tak přidat na další řádek)
3: Za tu hodnotu vložit jméno z řádku druhé označené buňky
4: Hodnoty v buňkách vzájemně prohodit

Je to soubor s plánovanými směnami a učel je ten, aby se zaznamenaly do komentářů prohozené směny (původní směna, s kým byl vyměněno, kdo vyměnil-místo Owner přihlášený uživatel-to se ale doplní samo při přidání komentáře)

Každopádně kdyby se ti do toho už nechtělo, tak moc děkuju i za tohle makro, třeba s pomocí dalších to dáme dohromady

[cmuch]

Tak takto

Kód: Vybrat vše

Sub ProhozeniKomentaru()

Dim Adresy, Adresa1, Adresa2 As Variant
Dim Coment1, Coment2, HodnotaBunky1, HodnotaBunky2 As String

  Adresy = Selection.Address
 
  If InStr(1, Adresy, ":", 1) = 0 And Selection.Count = 2 Then
    Adresa1 = Mid(Adresy, 1, InStr(1, Adresy, ",", 1) - 1)
    Adresa2 = Mid(Adresy, InStr(1, Adresy, ",", 1) + 1, Len(Adresy) - InStr(1, Adresy, ",", 1))
   
    If Range(Adresa1).Comment Is Nothing Then
      Range(Adresa1).AddComment
    End If
    Range(Adresa1).Comment.Text _
            Text:=Range(Adresa1).Comment.Text & Chr(10) & "- " & Application.UserName & Chr(10) & Range(Adresa1).Value & " " & Cells(Range(Adresa2).Row, "A")
   
    If Range(Adresa2).Comment Is Nothing Then
      Range(Adresa2).AddComment
    End If
    Range(Adresa2).Comment.Text _
            Text:=Range(Adresa2).Comment.Text & Chr(10) & "- " & Application.UserName & Chr(10) & Range(Adresa2).Value & " " & Cells(Range(Adresa1).Row, "A")
   
    'Coment1 = Range(Adresa1).Comment.Text
    'Coment2 = Range(Adresa2).Comment.Text
       
    'Range(Adresa1).Comment.Text Text:=Coment2
    'Range(Adresa2).Comment.Text Text:=Coment1

    HodnotaBunky1 = Range(Adresa1).Value
    HodnotaBunky2 = Range(Adresa2).Value
   
    Range(Adresa1).Value = HodnotaBunky2
    Range(Adresa2).Value = HodnotaBunky1
  End If
End Sub



[birgis]

Tak už je to skoro ono jen jsem provedl malinké změny

Kód: Vybrat vše

Sub ProhozeniKomentaru()

Dim Adresy, Adresa1, Adresa2 As Variant
Dim Coment1, Coment2 As String

  Adresy = Selection.Address
 
  If InStr(1, Adresy, ":", 1) = 0 And Selection.Count = 2 Then
    Adresa1 = Mid(Adresy, 1, InStr(1, Adresy, ",", 1) - 1)
    Adresa2 = Mid(Adresy, InStr(1, Adresy, ",", 1) + 1, Len(Adresy) - InStr(1, Adresy, ",", 1))
   
    If Range(Adresa1).Comment Is Nothing Then
      Range(Adresa1).AddComment
    End If
    Range(Adresa1).Comment.Text Text:=Range(Adresa1).Comment.Text & Chr(10) & Application.UserName & Chr(10) & Range(Adresa2).Value & " " & Cells(Range(Adresa1).Row, "A")
   
    If Range(Adresa2).Comment Is Nothing Then
      Range(Adresa2).AddComment
    End If
    Range(Adresa2).Comment.Text Text:=Range(Adresa2).Comment.Text & Chr(10) & Application.UserName & Chr(10) & Range(Adresa1).Value & " " & Cells(Range(Adresa2).Row, "A")
   
    Coment1 = Range(Adresa1).Comment.Text
    Coment2 = Range(Adresa2).Comment.Text
       
    Range(Adresa1).Comment.Text Text:=Coment2
    Range(Adresa2).Comment.Text Text:=Coment1


[b]   
    Range(Adresa1).Value= Adresa2
    Range(Adresa2).Value= Adresa1


[/b]
  End If
End Sub

Jen jsem se ještě snažil udělat ten 4 bod, tedy hodnoty v buňkách vzájemně prohodit, ale dostal jsem se jen k tomu, že mi to vrací chybu, nebo vloží adresu buňky, nebo je v obou buňkách stejná hodnota.

[cmuch]

Upraveno předchozí makro.
Vykomentoval jsem prohozeni komentářů, to tam asi být nemělo již od začátku.
Na konci je to prohození hodnot.

Ještě by asi bylo dobré ve vlastnostech komentářů zaškrtnout "automatickou velikost"

[birgis]

Ahoj, tak jsem to konečně vyzkoušel a je to přesně to, co jsem potřeboval.Odkomentoval jsem a upravil ty komentáře(jen malé změny) ale je to super.
Moc děkuju za pomoc..Máš u mě panáka