kunde

kunde profiilikuva
Joulu 2024
Vapaa kuvaus

Isaan Rules WFF CCC If you walked away smiling-then for you the price was right Keep Exceling Suosikkibändit/artistit: Queen, Rammstein, genesis, Bruce Bringsteen, Kino, Mandref Mann Earth band Who Lempikirjat: ohjelmointi... Suosikkipalstat Suomi24 Keskusteluissa: EXCEL, Kivitalot, EPS En pidä: pakkanen ja loskakelit Ruoka & juoma: loimulohi ja valkkari Linkit: http://www.kundepuu.com, Khorat Koulutus: --- Ammatti: Tiede/teknologia Työskentelen: freelancer Ase tai siviilipalvelus: yliluutnantti Siviilisääty: Varattu Lapset: --- Hakusanat: Thaimaa, korat, Excel, VBA, ACAD, CNC, Polyurea, EPS, MgO elementti

Liittynyt 20v sitten
7 aloitusta · 1377 kommenttia
Uusimmat aloituksetSuosituimmat aloituksetUusimmat kommentit
pari tapaa...

hard codella...

Sub Siirrä()
Range("A1,A3,A5").Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft)(1, 2)
Range("A1,A3,A5") = ""
End Sub

valitset solut hiirellä ...

Sub Siirrä2()
Selection.Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft)(1, 2)
Selection = ""
Range("A1").Select
End Sub
solumuotoiluksi
kokonaisluvuille 0;-0;;@
2 desimaalia esim. hinnoille 0,00;-0,00;;@
neuvotaas välillä vähemmän käytettyä NIMI muutujaa.
Eli lisätään nimi Tuote, jota voidaan sitten käyttää kaavoissa. Nimen käytön etuna mm. ettei tarvitse suojata soluja ja sen voi piilottaa käytäjältä ja siihen voi liittää kaavoja ja kaavoista tulee paljon selkokielisempiä lukea yms. Nyt kuitenkin jätin sen näkyville nimilistassa.

eli solussa käytät vain nimeä esim. = tuote*1,22 +30
tai esim ALV hinnan saat suoraan tekemällä nimen Loppuhinta ja viittaukseen laitat =tuote*1,22 ja sitten solussa kaavana =Loppuhinta joka vastaa siis kaavaa = tuote*1,22
...

kaikki muuten kuin kuten Paavali neuvoi (kelpoisuusehto), ja se solumuotoilukin toimii ihan OK, koska siinä on piilotettuna kaikki muut paitsi teksti, joka korvataan" valitse tästä" tekstillä

TAULUKON moduuliin...

eli jos solun B2 teksti muuttuu, niin muuttaa Tuotteen hintaa solutekstin mukaisesti. Muuta tuotenimet sopivksi ja lisää tarvittaessa ja muuta tuotenimet hinnat sopivaksi. Muista jos lisäät tuotteita koodiin niin lisää myös kelpoisuusehto luetteloon kanssa
jos haluat useampaan soluun tuotteita kopioi koodi ja muuta soluosoite (B2) ja muuta nimi muuttujan nimi esim. tuote1 jne

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2")) Is Nothing Then
Select Case Target
Case "Tuoli"
ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=30"
Case "Pöytä"
ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=130"
Case "Penkki"
ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=80"
Case "Kaappi"
ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=400"
Case "Sänky"
ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=800"
End Select
End If
End Sub
With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=IF(RC[-2]=TODAY();1;0)"
.FormatConditions(1).Interior.ColorIndex = 3
End With
ei tietoa onko sarakkeet peräkkäin vaiko siellä täällä ja mihin kopioidaan
mutta tällä alkuun...
muuttele kohdesarake sopivaksi, nyt A sarake ja alkaa A1.
Toimii siten, että maalaat kopioitavan alueen ja kopioi tiedot alkaen A1

moduuliin...

Sub YhteenSarakkeeseen()
Dim Alue As Range
Dim Sarake As Integer
On Error GoTo virhe
Set Alue = Application.Intersect(Selection, ActiveSheet.UsedRange)
Range("A:A") = ""
For Sarake = 1 To Alue.Columns.Count
If Sarake = 1 Then
Alue.Range(Cells(1, Sarake), Cells(Alue.Rows.Count, Sarake)).Copy Range("A1")
Else
Alue.Range(Cells(1, Sarake), Cells(Alue.Rows.Count, Sarake)).Copy Range("A65536").End(xlUp).Offset(1, 0)
End If
Next Sarake
poistu:
Exit Sub
virhe:
MsgBox "et valinnut sarakkeita!"
GoTo poistu
End Sub
siirrettävät tiedot esim C-sarakkeessa C1:C10 ja haluat ne taulukko2:een aina seuraavaan uuteen sarakkeeseen alkaen esim C1 ja sitten nollataan taulukko1:stä alue C1:C10 ?
liitä koodi nappiin

Private Sub CommandButton1_Click()
Range("A1:E10").Copy Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0)
End Sub
mutta vaikea antaa ohjetta noin ylimalkaiseen kyssäriin
Keep Excelling
@Kunde
käsitteet hiukan hukassa.
Työkirjan sisällä ei voi avata tai sulkea taulukoita ("välilehtiä")- vain aktivoida
mutta mai pen rai...
napin koodi...
Private Sub CommandButton1_Click()
Worksheets("Taul1").Activate
End Sub

Private Sub CommandButton2_Click()
Worksheets("Taul2").Activate
End Sub
Private Sub CommandButton1_Click()
Range("A1") = Range("A1") +1
End Sub
Private Sub CommandButton2_Click()
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim Löydetty3 As Range
On Error GoTo virhe
Set Löydetty = EtsiJaSiirrä(Range("Sheet1!A1"), "Sheet2").EntireRow
Union(Löydetty, Löydetty).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
Set Löydetty2 = EtsiJaSiirrä(Range("Sheet1!A1"), "Sheet3").EntireRow
Union(Löydetty2, Löydetty2).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
Set Löydetty3 = EtsiJaSiirrä(Range("Sheet1!A1"), "Sheet4").EntireRow
Union(Löydetty3, Löydetty3).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
Worksheets("Sheet1").Activate
Range("A1").Select
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
Worksheets("Sheet1").Activate
Range("A1").Select
End Sub

Function EtsiJaSiirrä(Hakuehto As Variant, Taulukko As String) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets(Taulukko).Activate
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set EtsiJaSiirrä = solu
EkaOsoite = solu.Address
Do
Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address   EkaOsoite
End If
End With
End Function
riippuu miten haluat automatisoida
esim. seuraavilla tapahtumilla
kun avaat työkirjan
kun suljet työkirjan
kun tallennat työkirjan
kun tulostat työkirjan
kun solussa oleva tieto muuttuu esim.asiakas
tuplaklikkaamalla taulukossa
hiiren oikealla klikkaamalla taulukossa
napilla

eiköhän tossa ollut tarpeeksi vaihtoehtoja ja sitten vaan tapahtumaan koodi esim
Sub Auto_Open()
Range("A1") = Range("A1") +1
End Sub
liitä makro moduuliin ja tee nappi joko
Kontrolli työkaluilla ja tuplaklikkaat nappia, jolloin koodisivu aukeaa ja lisäät makron nimen rivien väliin esim.

Private Sub CommandButton1_Click()
Testi
End Sub

tai jos teit sen Lomake työkaluilla niin liität Testi makron nappiin

Klara Vappen!
Keep Excelling
@Kunde
ja toiveesi toteutui...
muuta sopivaksi...

Function EtsiJaSiirrä(Hakuehto As Variant, Taulukko As String) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets(Taulukko).Activate
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set EtsiJaSiirrä = solu
EkaOsoite = solu.Address
Do
Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address   EkaOsoite
End If
End With

End Function

Sub Testi()
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim Löydetty3 As Range
On Error GoTo virhe
Set Löydetty = EtsiJaSiirrä(Range("Sheet1!A1"), "Sheet2").EntireRow
Union(Löydetty, Löydetty).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
Set Löydetty2 = EtsiJaSiirrä(Range("Sheet1!A1"), "Sheet3").EntireRow
Union(Löydetty2, Löydetty2).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
Set Löydetty3 = EtsiJaSiirrä(Range("Sheet1!A1"), "Sheet4").EntireRow
Union(Löydetty3, Löydetty3).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
Worksheets("Sheet1").Activate
Range("A1").Select
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
Worksheets("Sheet1").Activate
Range("A1").Select
End Sub
lisäämällä toisen haun ja muuttelemalla solualueita toimiva versio...
http://keskustelu.suomi24.fi/node/6001900#comment-31562054
Sub LAske()
Range("N2").Formula = "=IF(ISERROR(SUM(H2/C2*188)),"""",SUM(H2/C2*188))"
Range("N2").AutoFill Destination:=Range("N2:N13"), Type:=xlFillDefault
End Sub
haku toimii joko täydellisenä tai osittaisena- eli jos haetaan jukkaa niin tulos voi olla täsmähaulla jukka tai osittaisena sitten vaikkapa jukka k.
Molemmissa on ongelmana se, että jos haun tuloksena tulee useampi tulos niin mitä niistä käytetaan???
oletetaan lisää
taulukossa 2 on vain uniikkia nimiä, mutta taulukossa 1 voi olla tuplia tai erilailla kirjoitettuja esim. taul1 on jukka k., mutta taulukossa 2 onkin vain jukka. Tätätkö tarkoitit?
voisit antaa esim. tiedoista ja tarkentaa mitä haluat...
1. Miten nimet ja arvot on listattu. A sarakkeessa nimi ja B sarakkeessa vastaavasti luvut -vai?
2. Taulukossa 2 on siis kaikki nimet, mutta uupuu nimeä vastaavia lukuja?
ennenkuin koodin väsään, niin pari kyssäriä, ettei tartte turhaa työtä tehdä...
1. kuinka moneen taulukkoon tietoa siirretään?
2. voiko siirtää koko rivin, vai pitääkö olla A-AX ?
3. jos muuttuja muuttuu esim 2--->3 , niin poistetaanko taulukosta 2 tieto vai jääkö se sinne?

muuten on ihan piece of cake....
Excelin puolella siis taulukkonäkymässä ALT+F11 näppäinyhdistelmä avaa VBA editorin ja sieltä valitset valikosta INSERT/MODULE ja aukeavaan ikkunaan ((oletuksena Module1) kopioit koodin. Sitten vain suoritat ko proseduurin.
vaihtoehtoisesti valikon File/Tiedosto vasemmalla puolella olevaa excel kuvaketta klikkaamalla hiiren oikealla ja valitsemalla View Code/ Näytä koodi aukeaa VBA editori ja sitten samat jutut kuin edellisessäkin
45 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt