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
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
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
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
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
Hiukkasen spesiaalijuttujahan siinä on, mitä ei voi oppia kuin treenaamalla ja makronauhoittimella ei saa tommosta koodia aikaiseksi...
Keep Excelling
@Kunde
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
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
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
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
niin katsellaan jospa yhteinen ymmärrys löytyisi.

kundepuu(at)hotmail.com

Keep Excelling
@Kunde
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
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
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
Ei onnistu muuten
"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
=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
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
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
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
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
50 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt