kunde

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

Aloituksia

7

Kommenttia

1377

  1. If Target = Target.Offset(0, 2)

    eli kun joku solu muuttuu taulukossa(=Target , tossa koodissani) niin aluksi siinä oli testaus onko kyseessä A sarakkeen solu, joka muuttuu ja jos oli, niin sitten verrataan sitä saman rivin C sarakkeen soluun
    Target.Offset(0, 2) eli siirtymä 0 =sama rivi ja 2 =2 saraketta oikealle
    rivit menee + alaspäin ja - ylöspäin vastaavasti sarakkeet + oikealle ja -vasemmalle.

    elikä koodi aktivoituu kun taulukossa joku arvo muuttuu
    ekaksi testataan oliko A sarakkeen solu ja jos oli niin onko arvo sama kuin C sarakkeessa ja jos oli niin ilmoitus
    jälkimmäinen osa vastaavasti B sarakkeen soluille

    Keep Excelling
    @Kunde
  2. ko. TAULUKON moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns("A:A")) Is Nothing Then
    If Target = Target.Offset(0, 2) Then
    MsgBox "Arvo ei kelvollinen!", vbInformation
    Target = ""
    Target.Select
    End If
    End If
    If Not Intersect(Target, Columns("B:B")) Is Nothing Then
    If Target = Target.Offset(0, 1) Then
    MsgBox "Arvo ei kelvollinen!", vbInformation
    Target = ""
    Target.Select
    End If
    End If
    End Sub

    Keep Excelling
    @Kunde
  3. eli onko tarkoitus tarkistella sarakkeisiin A tai B syötettäviä arvoja ja verrata saman rivin C sarakkeen arvoon ja jos A:han tai B:hen syötettävä arvo on saman rivin C sarakkeen solussa niin varoitus?
    Jos näin niin vaihtoehtoja on...
    mutta odotellaan tarkennusta ennen kuin vastataan
  4. hiukan ylimalkainen kyssäri , mutta rivit joilla vastine on saat kätevästi allaolevalla koodilla(vanha postaus tänne ). Siinä sitten vaan tsekkaat rivitiedon ja suoritat tarvittavan makron(ilmeisesti sama kaikilla?)

    moduuliin...

    Option Explicit

    Sub Siirrä()
    Dim Löydetty As Range
    Dim solu As Range
    Dim haku As Variant
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("Sheet1").Activate
    haku = 1
    Set Löydetty = EtsiJaSiirrä(haku, Rows("1:30"))
    For Each solu In Löydetty
    'tähän makrotestaus soluosoitteen mukaan(rivi) ...
    MsgBox solu.Row
    Next
    Range("A1").Select
    Application.ScreenUpdating = True
    End Sub


    Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
    Dim solu As Range
    Dim EkaOsoite As String

    With HakuAlue
    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
  5. Hiukkasen spesiaalijuttujahan siinä on, mitä ei voi oppia kuin treenaamalla ja makronauhoittimella ei saa tommosta koodia aikaiseksi...
    Keep Excelling
    @Kunde
  6. esimerkissäsi on nyt sivulla 4 riviä tietoa... ekassa viestissäsi puhuit 46 rivistä, ok jos excelissä on tehty sivunvaidot aina samalla jaolla niin koodi pelaa. Jos ei ole sivunvaihtoja thety niin laita manuaalisesti esim . viimeisen esimerkkisi mukaisesti 5

    moduuliin...

    Sub MuotoileSivut()
    Dim Sivut As Long
    Dim Rivit As Long
    Dim Sivunvaihto As Long
    Dim Rivi As Long
    Dim Otsikkorivi As Long
    Dim i As Integer
    Dim j As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Rivit = Range("C65536").End(xlUp).Row()
    Sivunvaihto = ActiveSheet.HPageBreaks(1).Location.Row() - 1
    'jos sivunvaihtoja ei ole tehty joudut käyttämään manuaalista arvoa - esimerkissäsi oli nyt 5 riviä
    'eli hipsaa ylempänä oleva rivi Sivunvaihto = ActiveSheet.HPageBreaks(1).Location.Row() - 1 ja
    'poista allaolevalta riviltä hipsu Sivunvaihto = 5
    'Sivunvaihto = 5
    Sivut = (Rivit / Sivunvaihto) + 1
    Rivi = 1
    Otsikkorivi = 1
    For i = 1 To Sivut
    For j = 1 To Sivunvaihto
    Range("F" & Rivi) = Range("B" & Otsikkorivi)
    Range("G" & Rivi) = Range("D" & Otsikkorivi)
    Rivi = Rivi + 1
    If Rivi = Rivit + 1 Then Exit Sub
    Next
    Otsikkorivi = Otsikkorivi + Sivunvaihto
    Next
    Application.ScreenUpdating = True
    End Sub
  7. voisit nauhoittaa 2 eri makroa...
    eka makro ilman firman nimeä ja siirtää tiedot ja
    toka makro, jossa firman nimi mukana siirtää tiedot ja liität ne nappeihin ja sitten vaan napsuttelemaan...
    Jos ilman firman nimeä voit fiksata koodin tekemään kaikille nimille kerralla...
    ihan helppo juttu kaikenkaikkiaan toteuttaa
  8. Ilmeisesti haluat siirtää Data taulukosta tilaustiedot A15:E15 alueelta TILATUT TYÖT taulukkoon alekkain tehdä riville napin, jolla sitten tilauksen voi palauttaa alekkain Data taulukkoon alkaen riviltä 17?
    jos näin niin alla oleva koodi tekee sen. Helppo muokata sopivaksi
    moduuliin...

    Dim vika As Integer
    Sub LISAYS()
    Dim ylä As Double
    Dim vasen As Double
    Dim korkeus As Double
    Dim leveys As Double
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("TILATUT TYÖT").Activate
    vika = Range("B65536").End(xlUp).Row + 1
    'tiedot alkaen riviltä 7 jos ei niin muuta?
    If vika < 7 Then vika = 7
    Range("Data!A15:E15").Copy Destination:=Range("B" & vika)
    With Range("H" & vika)
    ylä = .Top
    vasen = .Left
    korkeus = .Height
    leveys = .Width
    End With
    ActiveSheet.Buttons.Add(vasen, ylä, leveys, korkeus).Select
    Selection.OnAction = "KOPIOINTI_POISTO"
    Range("B" & vika).Select
    Application.ScreenUpdating = True
    End Sub
    Sub KOPIOINTI_POISTO()
    Dim rivi As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    rivi = ActiveSheet.Buttons(Application.Caller).TopLeftCell.Row
    vika = Range("Data!B65536").End(xlUp).Row + 1
    'tiedot takaisin alkaen riviltä 17, jos ei niin muuta?
    If vika < 17 Then vika = 17
    Range("B" & rivi & ":F" & rivi).Copy Destination:=Range("Data!A" & vika)
    Rows(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Row).Delete Shift:=xlUp
    ActiveSheet.Shapes(Application.Caller).Select
    Selection.Cut
    Application.ScreenUpdating = True
    End Sub

    ja nappisi koodi pysyy samana

    Private Sub CommandButton4_Click()
    ' Tässä pitäisi tulla tilattu työ tulostukseen
    LISAYS
    End Sub
  9. halusitko vain kaksi solua siirtää aina joka sivulla vaiko kaikki sarakkeen C ja e solut?
    no all kahdelle solulle ja sitähän helppo muokata.
    moduuliin...
    Sub MuotoileSivut()
    Dim Sivut As Long
    Dim Rivit As Long
    Dim Sivunvaihto As Long
    Dim Otsikkorivi As Long
    On Error Resume Next
    Rivit = Range("C65536").End(xlUp).Row()
    Sivunvaihto = ActiveSheet.HPageBreaks(1).Location.Row() - 1
    'jos sivunvaihtoja ei ole tehty joudut käyttämään
    'Sivunvaihto = 46
    Sivut = (Rivit / Sivunvaihto) + 1
    For i = 0 To Sivut
    Otsikkorivi = 4 + i * Sivunvaihto
    Range("H" & Otsikkorivi) = Range("C" & Otsikkorivi)
    Range("I" & Otsikkorivi) = Range("E" & Otsikkorivi)
    Range("C" & Otsikkorivi) = ""
    Range("E" & Otsikkorivi) = ""
    Next
    End Sub

    tai vaihtoehtoisesti voit liittää Workbook_BeforePrint tapahtumaan ThisWorkbook, niin ei tartte koodia erikseen suorittaa, vaan se suoritetaan aina ennen printtausta

    Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Dim Sivut As Long
    Dim Rivit As Long
    Dim Sivunvaihto As Long
    Dim Otsikkorivi As Long
    On Error Resume Next
    Rivit = Range("C65536").End(xlUp).Row()
    Sivunvaihto = ActiveSheet.HPageBreaks(1).Location.Row() - 1
    'jos sivunvaihtoja ei ole tehty joudut käyttämään
    'Sivunvaihto = 46
    Sivut = (Rivit / Sivunvaihto) + 1
    For i = 0 To Sivut
    Otsikkorivi = 4 + i * Sivunvaihto
    Range("H" & Otsikkorivi) = Range("C" & Otsikkorivi)
    Range("I" & Otsikkorivi) = Range("E" & Otsikkorivi)
    Range("C" & Otsikkorivi) = ""
    Range("E" & Otsikkorivi) = ""
    Next
    End Sub
  10. niin katsellaan jospa yhteinen ymmärrys löytyisi.

    kundepuu(at)hotmail.com

    Keep Excelling
    @Kunde
  11. tolla tavalla mennään taulukon moduuliin. No nyt ollessasi VBA editoripuolella niin sulla pitäisi näkyä VBA project(työkirjan nimi tässä) ikkuna ja siinä pitäisi nyt olla avoinna sen taulukon koodi ikkuna mistä tulit edellä kuvaamallasi tavalla. Samassa ikkunassa näkyy vihreä excel merkkinen ikoni ja teksti ThisWorkbook. Tuplaklikkaa sitä ja liitä koodi ja tallenna.
    Antamani koodin tarkoitus olisi resetoida viimeisnen solu aina kun työkirja suljetaan. Tietenkin voi sen tehdä niinkin, että kun joku arvo muuttuu taulukossa niin tapahtuisi aina resetointi...

    Parempi tapa mennä ThisWorkbook moduuliin on klikata hiiren oikealla vasemmassa yläkulmassa olevaa excel ikonia (File/Tiedosto menun vasemmalla puolella. En nyt tiedä onko 2007 versiossa tätä enää?). Klikkaus avaa suoraan This workbook moduulin ja liitä koodi sinne ja tallenna.

    Toki kun tallennat 2007 muodossa, tiedoston koko kasvaa kanssa. Voit kokeilla tallentamista vanhemmissa Excel muodoissa ja todeta eron.

    No liitän nyt vielä yleismakron, jonka voit suorittaa mistä moduulista tahansa ja testata pelittääkö tää 2007 versiossa...
    eli siirrä kursori allaolevan koodipätkän jollekin riville ja paina F5. Kokeile sitten taulukoissa CTRL+END onko viimeinen rivi todellakin oikea?

    Sub Resetoi()
    For Each taulukko In ThisWorkbook.Worksheets
    x = taulukko.UsedRange.Rows.Count
    Next taulukko
    End Sub

    kepp Excelling
    @Kunde
  12. ThisWorkbook moduuliin...

    Private Sub Workbook_BeforeSave _
    (ByVal SaveAsUI As Boolean, Cancel As Boolean)
    For Each taulukko In ThisWorkbook.Worksheets
    x = taulukko.UsedRange.Rows.Count
    Next taulukko
    End Sub

    tallenna kun olet lisännyt koodiin ja avaa työkirja uudellen ja CTRL+End ja testaa toimiiko... ;-)
    Keep Excelling
    Kunde
  13. päiväykset sarakkeessa A ja purkaa ne sarakkeisiin B-G

    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim päiväys As Date
    Dim päiväys2 As Variant
    On Error GoTo virhe
    Application.EnableEvents = False
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
    päiväys = CDate(Target)
    päiväys2 = Split(päiväys, ".")
    If Len(päiväys2(2)) = 4 Then
    Range("B1") = Mid(päiväys2(2), 3, 1)
    Range("C1") = Right(päiväys2(2), 1)
    Else
    Range("B1") = 0
    Range("C1") = Right(päiväys2(2), 1)
    End If



    If Len(päiväys2(1)) = 2 Then
    Range("D1") = Left(päiväys2(1), 1)
    Range("E1") = Right(päiväys2(1), 1)
    Else
    Range("D1") = 0
    Range("E1") = Right(päiväys2(1), 1)
    End If

    If Len(päiväys2(0)) = 2 Then
    Range("F1") = Left(päiväys2(0), 1)
    Range("G1") = Right(päiväys2(0), 1)
    Else
    Range("F1") = 0
    Range("G1") = Right(päiväys2(0), 1)
    End If
    End If
    Application.EnableEvents = True
    Exit Sub
    virhe:
    MsgBox "päiväys virheellinen"
    Application.EnableEvents = True
    End Sub

    @Keep Excelling
    Kunde
  14. Ei onnistu muuten
  15. "että takapuolella ei ole kalvoa"
    mistäs tommosia kalvo-ovia saa?
    kalvo- ovissa käytettävät MDF levyt tulevat muutamalta valmistajalta ja niissä kalvojen värivalikoima on rajoitettua. Yleensä tausta on valkoinen.
    Etupuolen kalvoja on sitten saatavissa pilvin pimein ja muutamat tekevät pinnoitusta molemmin puolin samalla kuosilla.
    Itselleni teen semmoset kuviot oviin kuin itse haluan CNC ja printteri rules ...
    jos kiinnostaa mailaa
    kundepuu at hotmail.com
  16. =COUNTIF(OFFSET(Sheet1!$D$2;0;0;100;1);A2)

    ei toikaan pomminvarma ole jos lisäät rivillä 1 tai 2 uuden rivin, niin siirtyy samanlailla...
    mutta tolla nyt alkuun
  17. Sub Muutokset3()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
    ws.Range("A1") = 100
    ' tähän väliin muutokset, jotka haluan välilehdille tehdä
    Next
    End Sub

    koodissa olen viitannut aktiiviseen taulukkoon ws. yhtähyvin sen voi tehdä näin
    ws.activate
    Range("A1") = 100

    tosin aktivointi laukaisee muita tapahtumia ja laskentoja joten toi eka tapa on fiksumpi

    sulla on aktiivisena taulukko1 ja et ole koodissa siten mitenkään muuttanut eli loopissa muutokset kohdistuvat vain taulukko 1:seen
    laita range objektiin eteen viittaus aktiiviseen taulukkoon ws. tai käytä tota jälkimmäistä tapaa mikä lienee aloittelijalle helpompi ymmärtää...

    keep excelling
    @Kunde
  18. en nyt ymmrärrä kysymystä. Jos haluat kaikkiin taulukoihin niin allaoleva tekee sen. Toi sun ActiveSheet.Next.Select jutska on ihan hanurista...


    Sub a()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
    ws.Range("A1") = 100
    Next
    End Sub

    jos taas haluata muutokset kaikkiin muihin kuin johonkin tiettyyn tauluun niin allaolevilla onnistuu
    ekassa nimellä muihin ja nimettyy taulukkoon ja jälkimmäisessä numeroinnillamuihin ja indeksin mukaan, jos ei tiedetä nimeä

    Sub b()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
    'kaikki muut paitsi yhteenveto taulukko
    If Not ws.Name = "yhteenveto" Then
    ws.Range("A1") = 100
    'yhteenveto taulukko
    Else
    ws.Range("B1") = 100
    End If
    Next
    End Sub

    Sub c()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
    'kaikki muut paitsi viimeinen taulukko- esim. kun ei tiedetä nimeä
    If Not ws.Name = Worksheets(Worksheets.Count).Name Then
    ws.Range("A1") = 100
    'viimeinen taulukko
    Else
    ws.Range("B1") = 100
    End If
    Next
    End Sub
  19. toi sheet.count, sillä se laskee mukaan myös kaaviosivut- parempi olisi käyttää WorkSheets.Count

    vaihtoehtoisesti

    Sub a()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
    ws.Range("A1") = 100
    Next
    End Sub

    looppi ongelma
    Sub b()
    On Error GoTo virhe
    Sheets(1).Select
    Do Until ActiveSheet.Name = ""
    ActiveSheet.Range("B1") = 100
    ActiveSheet.Next.Select
    Loop
    virhe:
    End Sub

    ja kakkoskyssäriin
    kuten edellä jo mainitsin kandee olla tarkkana Sheet/WorkSheet kanssa. Voit testata asian tekemällä kaavion ja siirtämällä sen ensimmäiseksi taulukonvalitsimessa ja sitten muutat kaavion vaikka viimeiseksi ja testaa uudelleen...

    Sub ValitseEkataulukkoTaiKaavio()
    ' valitsee kaavion tai taulukon eli aina ensimmäisen
    Sheets(1).Select
    'valitsee ekan taulukon voi olla toinen, kolmas jne
    Worksheets(1).Select
    'valitsee ekan kaavion voi olla toinen, kolmas jne
    Charts(1).Select
    End Sub
  20. taulukon moduuliin...
    nyt tsekataan A1 ja testaillaan muutamaa ehtoa

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("A1"), Target) Is Nothing Then
    Select Case Target
    Case 1
    MsgBox 1
    Case 2
    MsgBox 2
    Case Else
    MsgBox "moi"
    End Select
    End If
    End Sub

    Keep Excelling
    @Kunde
    21. 50 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt