Excel-přesun čísel z buňky A do buněk B1-Bx Vyřešeno

[karlos]

Zdravím. Trochu jsem si zkomplikoval život a bez vaší pomoci se budu dlouho trápit, než se to naučím, nebo se zavěsím Ale k věci.

Na jednom stroji potřebuji monitorovat délku dráhy jezdce, který mačká pružiny. Další sledované veličiny jsou výstupy dvou tenzometrů. Délka a potažmo rychlost je snímána encodérem. Programem stroje je generována čtvrtá proměnná (lineární) a tou je časová osa, tu tvoří výstup čítače s hodinovým vstupem 50ms. Celý proces trvá cca 2s, čítač tedy nabývá hodnot 0-cca 100. Všechny proměnné jsou přenášeny do PC, respektive Excelu, rozhraním DDE. Časová osa je přenášena do buňky A1. Do buněk A2:A4 jsou přenášeny okamžité hodnoty encodéru a obou tentometrů. Až do tohoto místa vše umím a tudíž vše funguje. Co neumím, je donutit tabulku, aby :
při hodnotě čítače (A1) 1, přepsala stav buňky A2 do buňky B1, stav A3 do C1 a stav A4 do D1,
při hodnotě čítače (A1) 2, přepsala stav buňky A2 do buňky B2, stav A3 do C2 a stav A4 do D2,
při hodnotě čítače (A1) 3, přepsala stav buňky A2 do buňky B3, stav A3 do C3 a stav A4 do D3,
.
.
.
Díky za záchranu mého duševního zdraví a dost možná i života...

[Reklama]

[Branscombe]

navstevnik to urcite vymysli lepe a elegantneji, ale kdybych toto potřeboval napsat, tak bych ve VBA pro příslušný list vložil následující kód:

Kód: Vybrat vše

Private Sub Worksheet_change(ByVal Target As Range)

Dim CellA2 As Range, CellA3 As Range, CellA4 As Range

Set CellA2 = Range("A2")
Set CellA3 = Range("A3")
Set CellA4 = Range("A4")

If Range("A1") = "1" Then

Range("B1").Value = CellA2
Range("C1").Value = CellA3
Range("D1").Value = CellA4

ElseIf Range("A1") = "2" Then

Range("B2").Value = CellA2
Range("C2").Value = CellA3
Range("D2").Value = CellA4

ElseIf Range("A1") = "3" Then

Range("B3").Value = CellA2
Range("C3").Value = CellA3
Range("D3").Value = CellA4

End If

End Sub


[navstevnik]

V editoru VBA vloz do modulu prislusneho listu udalostni proceduru, je to pracovni verze, predpoklad je, ze bunky A1:A4 jsou naplnovany postupne pocinaje A1:

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim SBlk As Range
  If Not Intersect(Target, Me.Range("a4")) Is Nothing Then
    With Me
      ' kdyz je jiz naplnena A4
      If .Range("a4").Value <> vbNullString Then
        Set SBlk = .Range("a2:a4")
        Application.EnableEvents = False
        ' transpozice
        SBlk.Copy
        .Range("b" & .Range("a1").Value).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        Application.CutCopyMode = False
        ' odstranit obsah A1:A4
        SBlk.Resize(4, 1).Offset(-1, 0).ClearContents
        Application.EnableEvents = True
        Set SBlk = Nothing
      End If
    End With
  End If
End Sub

Ozvi se, jak to funguje.
Bude potreba asi doresit vyprazdneni bloku B1:Dxx,...., snad bude mozne i zjednoduseni

[karlos]

Díky za rychlé reakce. Testovat budu až zítra, takže reference budou až později.

ad Branscombe: hodnota proměnné v A1 je závislá na rychlosti cyklu, tedy čase a taktu čítače. V tuto chvíli bych musel nadatlovat smyčku 100krát a pokud bych chtěl zjemnit vzorkování encodéru a tenzometrů nejvyšším možným taktem 10ms, pak bych se dostal na hodnotu 500 Každpádně však dík za velmi jednoduchý a snadno pochopitelný postrk kupředu.

ad Návštěvník: Jelikož se chystám usnout a cítím se trochu vyždímaný, tak to zatím moc nepobírám. Ráno snad budu moudřejší... no uvidíme... Buňky A1:A4 jsou zaplněny stále a jejich hodnota se mění za letu. Celé to mám vymyšlené tak, že by se to mělo chovat v principu, jako PCM. Změny posuvu a váhy jsou převáděny na číselné posloupnosti a jejich vzorky jsou ukládány do tabulky "samplovací frekvencí" 20Hz, přičemž každý vzorkovací impuls je očíslovaný pro snadnější vytvoření tabulky (A1).

[karlos]

Omlouvám se za pozdní report. Ale pár hodin jsem zabil opravou jiného stroje a pak jsem absolvoval sezení s vedením firmy na téma grafů a 100% kontroly pružin na váhu u stroje, kterého se týká tento topic.

První kód nefunguje a druhý jsem ještě nezkoušel, nicméně mám obavu, že se mu také nebude chtít pracovat mravně, právě pro již zmiňovanou podmínku zaplnění poslední (A4) buňky. Určující pro přepis by měla být změna buňky A1, pokud budou buňky A2:A4 prázdné, nic se neděje, nic se nepřepíše. Mazání buněk B1:Dn není nutné. V novém cyklu se přepíší novými hodnotami.

O půl hodiny později...
Bohužel ani druhý kód nemaká. Mám však nové poznatky. Pokud jsem v obou případech odstranil z buněk A1:A4 propojení na program UniDDE =UniDDE|Items!'lblDDE(1)' ... =UniDDE|Items!'lblDDE(4)' a na jejich místo dosadil konkrétní čísla, pak se čísla přepisovala do správných buněk. Tedy v případě kódu od návštěvníka. Kód od Branscomba se po prvním přepisu zacyklil a učinil Excel neovladatelným.

[navstevnik]

To, ze muze nastat stav, kdy bude zapsana nova hodnota do A1 a nebudou zapsany dalsi hodnoty A2:A4 jsi neuvedl. Cekani na zapis posledni hodnoty jsem zvolil z duvodu uspory casu behu procedury, cca 1/5 proti provedeni bez cekani, coz muze mit negativni dopad pri taktu 10 ms.
Takze upravena procedura:

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim SBlk As Range
  With Me
    If Not Intersect(Target, .Range("a1:a4")) Is Nothing Then
      Set SBlk = .Range("a2:a4")
      Application.EnableEvents = False
      ' kdyz je naplnena A1
      If Target.Address = "$A$1" Then
        ' odstranit obsah A2:A4
        SBlk.ClearContents
      End If
      ' transpozice
      If .Range("a1").Value <> vbNullString Then
        SBlk.Copy
        .Range("b" & .Range("a1").Value).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        Application.CutCopyMode = False
      End If
      Application.EnableEvents = True
      Set SBlk = Nothing
    End If
  End With
End Sub

Pro pripad chyboveho ukonceni behu, kdy bylo deaktivovano prepocitavani listu ( Application.CutCopyMode = False) zavolej proceduru pro obnoveni:

Kód: Vybrat vše

Sub AEE()
Application.EnableEvents = True
End Sub

Protoze nemam moznost realneho overeni jinak nez tvym prostrednictvim, jsem zvedav na vysledek.
Funkcnost procedury mohu overit pouze (do standardniho modulu):

Kód: Vybrat vše

Option Explicit

Sub test()
  Dim i As Integer, Wsht As Worksheet
  Dim T As Single
  Set Wsht = ThisWorkbook.Worksheets("list1")
  T = Timer()
  Application.ScreenUpdating = False
  For i = 1 To 100
    With Wsht.Range("a1")
      .Value = i
      .Offset(1, 0).Value = i ' + 10
      .Offset(2, 0).Value = i + 100
      .Offset(3, 0).Value = i + 1000
    End With
  Next i
  Application.ScreenUpdating = True
  Debug.Print Timer() - T
  Set Wsht = Nothing
End Sub

[karlos]

Tak zase nic Pokud jsem z A1 vymazal odkaz na UniDDE a nahradil jej konkrétní číslicí, pak kód učinil pokus o přepis a zároveň vymazal odkazy na UniDDE z A2:A4, čímž ztratil kontakt s tímto programem, přenášejícím hodnoty analogových veličin do tabulky.

Víkend na krku a jelikož před chvílí na inkriminovaném stroji začala druhá směna výrobu a tím mě odsunula od možnosti experimentů, ponechme problém uzrát. Pokusím se tvými kódy přes víkend prokousat a pochopit je, abych ti mohl blíže konkretizovat, co ano a co ne. Prozatím díky za tvůj čas a cenné rady.

[navstevnik]

Koukal jsem na informace o UniDDE, nejspis postaci odstranit mazani obsahu bunek A2:A4. Procedura reaguje na zmeny v bunkach A1:A4 a podle hodnoty xx v A1 transponuje obsah bunek A2:A4 do bunek Bxx:Dxx:

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim SBlk As Range
  With Me
    If Not Intersect(Target, .Range("a1:a4")) Is Nothing Then
      Set SBlk = .Range("a2:a4")
      Application.EnableEvents = False
      ' transpozice
      If .Range("a1").Value <> vbNullString Then
        SBlk.Copy
        .Range("b" & .Range("a1").Value).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        Application.CutCopyMode = False
      End If
      Application.EnableEvents = True
      Set SBlk = Nothing
    End If
  End With
End Sub

Komunikaci mezi PC a zarizenim si v Excelu dopln podle konkretni implementace UniDDE.

[karlos]

Dík. V pondělí to testnu. Přeji hezký víkend.

[karlos]

Asi nejsem jediným, kdo není v zaměstnání svým pánem tak se tedy stalo, že jsem musel předchozí pokusy zastavit a věnovat se jiné práci. Nyní nadchází dny zděšení, kdy šéf zjistil, že mám fyzický defekt, mám totiž jen dvě ruce a pro jednu práci nestíhám druhou, třetí, čtvrtou, pátou a do toho ještě opravovat závady na stávajících strojích, neboť světe div se, jsou dovolené a jsem tu sám... ostatně je to stejné každý rok

Ale dost zbytečných řečí. Poslední script má snahu fungovat, je zde však ono pověstné ALE. Aby se script provedl, musí se hodnota v buňce A1 "odentrovat", což utilita pro komunikaci stroj>Excel nedělá. Přikládám tabulku, ve které se vkládají hodnoty "od stroje" do buněk A5:A8, tyto se kopírují do A1:A4. Změna hodnoty A1 (bez [enter]) má provést přepsání hodnot A2 do buněk B(A1), A3 do buněk C(A1) a A3 do buněk D(A1).

Předem díky za pomoc a omlouvám se za přerušení, které nebylo zcela v mých rukou. Koneckonců nám jen dvě

[karlos]

Top.

[karlos]

Problém vyřešen pomocí vývojového prostředí Promotic. Děkuji všem, kteří se mi snažili pomoci.