kunde
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 sitten
Muokkaa profiilia7 aloitusta · 1377 kommenttia
- 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 kunde@hotmail.fi
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