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
oletuksena nyt eka taulukko, jota testataan

Private Sub Workbook_BeforePrint(Cancel As Boolean)

Dim mySolu As Range

If ActiveSheet.Name = Worksheets(1).Name Then
For Each mySolu In Range("tarkistaNamaSolut")
If mySolu = "" Then
Cancel = True
MsgBox ("Et voi tulostaa! tietoja puuttuu ")
Exit Sub
End If
Next mySolu
End If

End Sub
kysyjä halusikin vain arvot...

Sub Kopioi()
On Error Resume Next
Range("Taul1!B2:M2").Copy 'muuta aluetta tarvittaessa
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues) 'kopioi B sarakkeesta alkaen muuta tarvittaessa
End Sub
Mikä virheilmoitus tulee jos hipsaat On Error Resume Next rivin?
Ainakin mulla kopioi Taul1 alueen B2:M2 Taul2 aina seuraavalle vapaalle riville B sarakkeessa
"Hmm testasin tuon ja sehän näyttä viimeisestä rivistä seuraavan rivin, eli joudutaan vähentämään yksi rivi pois:"

offset on 0-pohjainen-eli montako riviä ylä- tai alapuolella sijaitsevaan soluun viittauksen vasemman yläkulman solu viittaa tai montako saraketta vasemmalle tai oikealle viittauksen vasemman yläkulman solu viittaa

eli tästä johtuen joudut vähentämään -1 tostahan olis helppo tehdä UDF
Sub Kopioi()
Dim KopioAlue As Range
On Error Resume Next
Set KopioAlue = Range("Taul1!B2:M2")'muuta aluetta tarvittaessa
KopioAlue.Copy Destination:=Range("Taul2!B65536").End(xlUp).Offset(1, 0) 'kopioi B sarakkeesta alkaen muuta tarvittaessa
End Sub
http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000024055562

vastasin siellä... ;-)
http://www.appspro.com/Utilities/ChartLabeler.htm

Helpoin tapa on ladata joku XY Chart Labeler esim. www.appspro.com
tekee just sen mitä pyytelet

moduuliin...
Sub KopioiPoista()
Dim vika As Integer
Dim vika2 As Integer
Dim vika3 As Integer
Dim i As Integer
On Error Resume Next
vika = Range("A65536").End(xlUp).Row
For i = vika To 1 Step -1
If i = 1 Then Exit Sub
If Range("A" & i) = Range("A" & i).Offset(-1, 0) Then
vika2 = Range("A" & i).End(xlToRight).Column
vika3 = Range("A" & i).Offset(-1, 0).End(xlToRight).Column
Range("B" & i).Resize(1, vika2 - 1).Copy Destination:=Range("A" & i).Offset(-1, vika3)
Range("A" & i).EntireRow.Delete
End If
Next
End Sub
Apuohjelmalla vaan saat tehtyä vippaskonsteja ja originaali kaavio tallentuu ihan normaalisti. Jos avaat sen ilman apuohjelmaa no problems...
http://www.appspro.com/Utilities/ChartLabeler.htm
lue tuolta

http://www.jkp-ads.com/Articles/RegisterUDF00.htm
muistaakseni argumenteille melko hankala tehdä helppiä, voi olla, että uusimmassa versiossa sekin mahdollista, mutta jotakin voi tehdä sentään helpostikin

moduuliin...

Sub Auto_Open()
Dim kuvaus As String
kuvaus = "Laskee pari lukua yhteen "
Application.MacroOptions Macro:="Testi", Description:=kuvaus, Category:=9
End Sub
Public Function Testi(ByRef Luku1 As Integer, _
ByRef Luku2 As Integer) As Integer
Testi = Luku1 + Luku2
End Function

Private Sub Auto_Close()
Application.MacroOptions Macro:="Testi", Description:=Empty, Category:=Empty
End Sub
vaikeampi tapa ilman koodia ja helpompi koodilla

ilmankoodia

1.Tallenna työkirja web sivuna
2. Lisää kommentti soluun
3. Tuplaklikkaa kommentin reunan päällä, missä on niitä palloja
4.Lomakkeelta valitse Colors and Lines
5. Color alasvetovalikosta valitse Fill Effects
6. valitse Picture
7. Klikkaa Select Picture
8.Liitä kaaviokuva websivun liitekansiosta
9. ok
10.ok


koodilla
moduuliin...

Sub LisaaKaavio()
Dim alue As Range
Dim muoto As Object
Set alue = ActiveCell
If Not alue.Comment Is Nothing Then
alue.Comment.Delete
End If
ActiveSheet.ChartObjects(1).Activate
ActiveChart.Export Filename:="C:\KommenttiKaavio.gif", FilterName:="GIF"
Set muoto = alue.AddComment("")
muoto.Shape.Fill.UserPicture "C:\KommenttiKaavio.gif"
Range("A1").Select 'kaavion valinnan poisto
End Sub
siellä keeroin miten useampi rivisiä comboja tehdään
mutta kertauksesi:
BoundColumn siihen sen sarakkeen numero minkä haluat näkyvän
ColumCount tietojen sarakkeiden määrä
ColumnWidths esim 10;10;10;0 4 sarakkeelle ja viimeistä ei näytetä
ListFillRange alue mistä haetaan tiedot esim 4 saraketta A1:D100

ja sitten koodi objektiin
Private Sub ComboBox1_Change()
Range("A1") = ComboBox1.Column(0) ' eka sarake
Range("B1") = ComboBox1.Column(1) 'toka jne
Range("C1") = ComboBox1.Column(2)
Range("D1") = ComboBox1.Column(3)
End Sub

ei se ton vaikeempaa ole

keeep Exceling ;-)
käyttää win API komentoa sleep ja aika annetaan millisekunteina eli 1000= 1 s

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Commandbutton1_Click()
MsgBox "hei"
Sleep 1000
MsgBox "moro"
End Sub
kopioi tiedot Taul2
Range("A2:A4").Copy Range("Taul2!A65536").End(xlUp)

tyhjentää tiedot Taul1
Range("Taul1!A1:A4")=""
tutkailin useita variaatioita, mutta ei taida onnistua ilman VBA:ta tämäkään juttu. Sen avulla se onkin piece of cake

eli kun D6 syötetään jotakin C1 tulee tämän päivän päiväys ja kun D6 on tyhjä on myös C1 tyhjä

taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("D6")) Is Nothing Then
If Not Range("D6") = "" Then
With Range("C1")
.Value = Date
.EntireColumn.AutoFit
End With
Else
Range("C1") = ""
End If

End If
End Sub
lomakkeen moduuliin...

ja kaikki nimet nyt oletusnimiä ja alueet nimetty checkbox captionin nimillä työkirjassa esim Alue1, Alue2 jne

Option Explicit
Dim ctl As Control
Public MyMulti As Range
Sub MaaritaAlue()
Set MyMulti = Nothing
On Error Resume Next
For Each ctl In UserForm1.Controls
If TypeName(ctl) = "CheckBox" Then
If ctl.Value = True Then
If MyMulti Is Nothing Then
Set MyMulti = Range(ctl.Caption)
Else
Set MyMulti = Application.Union(MyMulti, Range(ctl.Caption))
End If
End If
End If
Next
'MsgBox MyMulti.Address
End Sub

Private Sub CheckBox1_Click()
MaaritaAlue
End Sub

Private Sub CheckBox2_Click()
MaaritaAlue
End Sub

Private Sub CheckBox3_Click()
MaaritaAlue
End Sub

Private Sub CheckBox4_Click()
MaaritaAlue
End Sub

Private Sub CommandButton1_Click()
On Error GoTo virhe
MyMulti.Select
'Me.Hide
'ActiveSheet.PrintPreview False
Exit Sub
virhe:
MsgBox "sinun täytyy valita ainakin yksi alue tulostusta varten!", vbInformation
End Sub
hakee nyt Taul1 ja Taul2 A-sarakkeen tiedoista Taul3 A-sarakkeeseen uniikit tiedot

moduuliin...

Sub Uniikit()
Dim Vika As Double
Dim eka As Range
Dim toka As Range
On Error Resume Next

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Worksheets("Taul1").Activate
Vika = Range("A65536").End(xlUp).Row
Set eka = Range("A1:A" & Vika)

Worksheets("Taul2").Activate
Vika = Range("A65536").End(xlUp).Row
Set toka = Range("A1:A" & Vika)

Sheets("Huuhaa").Delete
Worksheets.Add().Name = "Huuhaa"
Worksheets("Huuhaa").Activate
Range("A:A") = ""
Range("A1") = "uniikit"
eka.Copy Range("A2")
Vika = Range("A65536").End(xlUp).Row + 1
toka.Copy Range("A" & Vika)

Worksheets("Taul3").Activate
Sheets("Huuhaa").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
Range("A1").Select
Sheets("Huuhaa").Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Set eka = Nothing
Set toka = Nothing
End Sub

Keep Excelling :-)
Lisää ohjausobjekti valikosta luetteloruutu ja muokkaa sen ominaisuuksia.
esim. sun tapauksessa vaikka näin

BoundColumn=2 (arvot toisesta sarakkeesta)
ColumCount=2 (montako saraketta tietoja)
ColumWidths= 10pt;0pt
LinkedCell=C1 (solun osoite , missä tiedot näytetään)
ListFillRange=A1:B10 (alue missä tiedot on)

ja siinäpä se!
Keep Excelling ;-)
tosiaan excel ei aina päivitä viimeistä solua ja tossa alempana tulikin vinkki siihen miten sen saa päivittämään viimeisen solun ja siten siis CTRL+ END toimii oikein. eli deletoi tyhjat rivit ja sarakkeet alueen ulkopuolelta ja tallentaa tiedoston

Tutkailin asiaa VBA:n kannalta ja seuraava koodi pakottaa excelin päivittämään viimeisen solun. Tosin samalla katoaa Undo muisti... (mutta niinhän se katoaa tallennuksessakin)
eka koodi resetoi aktiivisen taulukon vika solun ja toka koodi tekee sen kaikille taulukoille ennen tallennusta ja näin ollen estää tiedoston turhan kasvun samalla

lisää ThisWorkbook moduuliin...

Private Sub Workbook_SheetSelectionChange _
(ByVal Sh As Object, ByVal Target As Excel.Range)
vika= Sh.UsedRange.Rows.Count
End Sub

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

keep exceling :-)
65 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt