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
Excelistä tuo työkalu puuttuu...(voi olla 2010, mutta ei sitä aikaisemmissa versioissa ainakaan ole)

Koodillakin paska duunata, kun pitäisi tietää muokattava merkki solussa ja se ei ole helppoa. Koko solun muokkaus sensijaan piece of the cake, mutta siitähän nyt ei ollutkaan kyse.
Toki aktiivisen solun merkit voisi kopioida lomakkeelle ja sitten muokata valittuja merkkejä yksitellen ja lopuksi palauttaa takaisin muokattuna aktiiviseen soluun, mutta työlästä työlästä...
moduuliin...
muuta hakusolu=K1 ja hakualue= A1:D10 sopiviksi

Function EtsiiKaikkiAlueelta(Hakuehto As Variant, HakuAlue As Range) As String
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
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
EkaOsoite = solu.Address
Do
EtsiiKaikkiAlueelta = EtsiiKaikkiAlueelta & ", " & solu.Address
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
EtsiiKaikkiAlueelta = Right(EtsiiKaikkiAlueelta, Len(EtsiiKaikkiAlueelta) - 1)
End Function

Sub Etsi()
Dim solut As String
On Error GoTo virhe
solut = EtsiiKaikkiAlueelta(Range("K1"), Range("A1:D10"))
MsgBox Range("K1") & " löytyi solu(i)sta" & solut
Exit Sub
virhe:
MsgBox "ei löytynyt!"
End Sub

Keep EXCELing
@Kunde
onhan siinä paljonkin vikaa...
ei toi tee muuta kuin tulostaa... eli tietenkin kysyy polkua jne.
eikä koodisa ole mitään sähkärin lahettämistäkään-ei nauhuri nauhoita noita juttuja...

vaatii koodaajaa...

,-) Kunde
ok näin yksinkertaisena tapauksena (yksi väri)
anteeksi virheeni

by the way niin se aika vaan rientää
vastakysymys ;-)

kuinka teet 6-7 erilaista värimuotoilua solulle ilman koodia (XL2003- uudemmissahan saattaa olla vaihtoehtoja jo useita, mutta tässä versiossa 3 ehdollista muotoilua)
ei onnaa useammalle solulle ilman koodia...

ko taulukon moduuliin...

vain solut A1:G1 muuttaa väriä...

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("G1") = 0 Then
Range("A1:G1").Interior.ColorIndex = 6
Else
Range("A1:G1").Interior.ColorIndex = xlNone
End If
End Sub

tai koko rivi muuttaa väriä...

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Range("G1") = 0 Then
Rows("1:1").Interior.ColorIndex = 6
Else
Rows("1:1").Interior.ColorIndex = xlNone
End If
End Sub

Keep EXCELing
@Kunde
pikkusen foorumilla hakua peliin ja vastaavia kyssäreitä löytyy ja mun vastaukset niihin, ei tartte kuin sarakkeita ja nimiä muutella...

moduuliin...

Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
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

Sub EtsiijaPoistaa()
Dim vika As Long
On Error Resume Next
vika = Worksheets("Sheet2").Range("D65536").End(xlUp).Row
For Each solu In Worksheets("Sheet2").Range("D1:D" & vika)
EtsiJaSiirrä(solu, Columns("A:A")).EntireRow.Delete
Next
End Sub

Keep EXCELing
@Kunde
lisää viittaus Microsoft Scripting Runtime

moduuliin...

Sub HaePDf()
Dim FSO As Scripting.FileSystemObject
Dim LähdeKansio As Scripting.Folder
Dim Tiedosto As Scripting.File
Range("A:A") = ""
Range("A1").Select
Set FSO = New Scripting.FileSystemObject
Set LähdeKansio = FSO.GetFolder("E:\Testi\")
For Each Tiedosto In LähdeKansio.Files
If Right(Tiedosto, 4) = ".pdf" Then
ActiveCell = Left(Tiedosto.Name, Len(Tiedosto.Name) - 4)
ActiveCell.Offset(1, 0).Select
End If
Next Tiedosto
Columns("A:A").AutoFit
Set Tiedosto = Nothing
Set LähdeKansio = Nothing
Set FSO = Nothing
End Sub


Keep EXCELing
@Kunde
tekee sarjan aktiivisesta saolusta alaspäin...

moduuliin...

Sub Sarja()
Dim i As Long
For i = 1457 To 1876
ActiveCell = "KLF" & i & "-11"
ActiveCell.Offset(1, 0).Select
Next
End Sub

Keep EXCELing
@Kunde
kaavion teko ohjetta en ymmärtänyt...
moduuliin...

Option Explicit

Sub Siirrä()
Dim vika As Long
Worksheets("Sheet1").Activate
vika = Range("G65536").End(xlUp).Row
Worksheets("Sheet2").Columns("A:B") = ""
Worksheets("Sheet1").Range("G1:G" & vika).Copy Worksheets("Sheet2").Range("A1")
Worksheets("Sheet1").Range("B1:B" & vika).Copy Worksheets("Sheet2").Range("B1")
Worksheets("Sheet2").Activate
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
' kaavionteko
End Sub


Keep EXCELing
@Kunde
helpistähan noi löytyi heti.
tossa nyt yleisimmät variaatiot...

Sub Sivunumerot()
ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberLeft)
'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberRight)
'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberCenter)
'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberInside)
'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberOutside)
ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabic
'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabicFullWidth
'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseLetter
'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseRoman
'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInCircle
'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInDash
'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleUppercaseLetter
'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberLeft)
'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberRight)
'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberCenter)
'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberInside)
'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberOutside)
'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabic
'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabicFullWidth
'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseLetter
'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseRoman
'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInCircle
'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInDash
'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleUppercaseLetter
End Sub

Keep WORDing
@Kunde
Sub LisääKuva()
Dim p As Object
Dim ylä As Double
Dim vasen As Double
Dim leveys As Double
Dim korkeus As Double
Dim i As Long
Dim kuva As String

'muuta SOLU
Range("A50").Select
'muuta SOLUALUE
'Range("A50:D50").Select
For i = 1 To 2
'muuta POLKU JA NIMI
kuva = "E:\BELL" & i & ".jpg"
Set p = ActiveSheet.Pictures.Insert(kuva)
With p
.Top = Selection.Top
.Left = Selection.Left
.Width = Selection.Offset(0, Selection.Columns.Count).Left - Selection.Left
.Height = Selection.Offset(Selection.Rows.Count, 0).Top - Selection.Top
End With
Selection.Offset(1, 0).Select
Next
Set p = Nothing
End Sub
moduuliin....
muuta nimet sopiviksi

Option Explicit

Sub Kuvakoe()
' solualueelle kuva
LisääKuva "E:\testi.jpg", Range("A50:D65")
'yksittäiseen soluun kuva
'LisääKuva "E:\testi.jpg", Range("A50")
End Sub

Sub LisääKuva(Tiedosto As String, Solu As Range)
Dim p As Object
Dim ylä As Double
Dim vasen As Double
Dim leveys As Double
Dim korkeus As Double
Set p = ActiveSheet.Pictures.Insert(Tiedosto)
With p
.Top = Solu.Top
.Left = Solu.Left
.Width = Solu.Offset(0, Solu.Columns.Count).Left - Solu.Left
.Height = Solu.Offset(Solu.Rows.Count, 0).Top - Solu.Top
End With
Set p = Nothing
End Sub

Keep EXCELing
@Kunde
Sub PuraOsoitteet()
Dim i As Long
Dim Postinumero As Integer
Dim solu As Range
Dim vika As Long
vika = Range("C65536").End(xlUp).Row
For Each solu In Range("C1:C" & vika)
For i = Len(solu) To 1 Step -1
If IsNumeric(Mid(solu, i, 1)) Then
Postinumero = Postinumero + 1
End If
If Postinumero = 5 Then
solu.Offset(0, 1) = Left(solu, i - 1)
solu.Offset(0, 2).NumberFormat = "@"
solu.Offset(0, 2) = Mid(solu, i, 5)
solu.Offset(0, 3) = Mid(solu, i + 6)
Exit For
End If
Next
Postinumero = 0
Next
End Sub
onhan noita mun väsäämiä mallikoodeja useita tällä foorumilla- eli onnistuu melko kivuttomasti. ..
tarttee vaan tarkemmat tiedot
mistä kansiosta ja mistä soulista ja mihin soluihin tieto haetaan (summataan)
niinpä...
et kertonut aluksi, että haluat tulostaa useampia välilehtiä eri nimillä ja hakoteillä olin taas...
Ei taida onnistua tuo, koska printteri näköjään kuitenkin käyttää tallenna lomaketta tulostaessaan taulukkoa ja kokeilin syöttää siihen sitten tietoja eri tavoilla (osaan kyllä ton) ja virhettä pukkaa aina ja ohjeita ei loe mikä mattää :-(
Netistä löysin ilmaisen toimivan version sun tapaukseen( ei tartte paljoa fiksata Print Multiple Worksheets to Multiple PDF Files koodia) ja tuntui toimivan ihan jees...

koodi
http://www.excelguru.ca/node/21#MultiMulti

printteri
http://sourceforge.net/projects/pdfcreator/

Keep EXCELing
@Kunde
himassahan sitä ollaan taas!

tää koodin pätkä pitäisi toimia, eli vaihtaa oletustulostimen PDF-XChangeksi ja tulostaa tiedoston ja sitten palauttaa oletustulostimen takaisin

Ei ole koneella tota PDF-XChange tulostinohjelmaa, mutta eiköhän sen omimaisuuksista voi suoraan määritellä tarvittavat polut ja oletusnimet....

eli menusta FILE/PRINT ja avautuvasta valikosta valitset ton PDF-XChange tulostimen ja klikkaa vieressä olevaa PROPERTIES nappia ja sitten vaan kattelet, jospa jossain olisi tallennusasetukset ja rukkaat ne kohilleen...
polku= C:\liitteet
nimi=raportti

moduuliin...

Dim Oletustulostin As String
Oletustulostin = Application.ActivePrinter
Application.ActivePrinter = "PDF-XChange 4.0 on Ne05:"
ActiveSheet.PrintOut
Application.ActivePrinter = Oletustulostin
End Sub


Keep EXCELing
@Kunde
suomenkielistä kunnon kirjaa ei ole eikä tule kun kopioidaan vanhaa ja lisätään pari uutta juttua malkliksi vanhaan kirjaan -rahastusta...
laita email mulle niin kerron mistä saat [email protected]

tää keskustelupalstan softa on ihan p*tä. Ei edes kooditageja ole saati liitetiedostojen liittämismahdollisuutta ei ole

kunpa olisi aikaa paneutua omaan foorumiin niin siellä homma toimii...
katellaan jos aikaa riittäisi sen ylläpitoon, infoan kun alan pyörittämään Excel osiota
todennäköisesti asia on kuten itsekin totesit, eli navigaattorissa homma tehdään. Olen muistaakseni kerran nähnyt tommosen tekstitiedoston ja ei siinä ollut mitää muuta kuin paikkatietoja, eli ilmeisesti samassa kansiossa olevaa kuvaa sitten käytää kordinaattipisteille, joten villi arvaukseni on, että pitää vaan tehdä erilliset kansiot kaikille pankeille
esim. näin

sarakkeeseen A oma solumuotoilu pp.kk ppp

solu A1=1.7.2011 (1.7. pe)
solut A2 ja A3 tyhjiä
solu A4=2.7.2011 (2.7. pe)
solut A5 ja A6 tyhjiä
maalaa alue A1:A6 ja raahaa hiiren vasemmallaalaspäin tarpeellinen määrä
CTRL+TAB
27 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt