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
office 2007 taitaa olla 50 maksimi määrä tai mitä ruudulle mahtuukin... ainoa keino olisi VBA:n avulla tehdä valikkoon muutokset ja lisätä sitä kautta tiedostojen määrää, mutta kun kyseessä Word, niin en jaksa edes ajatella makron tekoa ...
no vaikka noin... Private Sub ComboBox1_Change() Select Case ComboBox1.ListIndex Case 0 'eka valinta Range("A10").Select Case 1 ' toka valinta Range("A30").Select Case 2 ' kolmas valinta jne... Range("A100").Select Case Else MsgBox "tänne ei pitäs tulla!" End Select End Sub
vastaa kunde
kaikille kerron,jotka mailaavat
mailaa mulle

[email protected]

niin kerron paikan mistä ladata...
Tallenna taulukko HTML muodossa ja Excel tekee automaattisesti kaavioista .GIF

Toinen tapa
VBA:lla pari rivia koodia...
ja liitä tänne semmoinen toimiva versio tosta suojauksesta. Suojauksien säätely on muuttunut vuosien varrella aika paljon ja työni(asiakkaani)johdosta minulla ei ole uudempaa 2007 versiota käytössäni.
VBA editorin puolella valitse valikoista
Tools/VBAProject Properties -avautuu lomake ja siitä klikkaa Protection välilehti ja täppä kohtaa Lock Project for viewing ja salasanan kirjoitat pariin kertaa ja OK. Tallenna työkirja ja avaa uudelleen nyt koodit näkyvät vain salasanalla.

Muutin koodin solunmuutos tapahtumaan...
koodissa salasana on oltava sama kuin taulukon suojaus salasana.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A1")) Is Nothing Then
With ActiveSheet
.Unprotect Password:="Kunde"
If Range("A1") = 1 Then
Target.Locked = True

Else
MsgBox " Anna solun arvoksi 1"
Range("A1").Select
End If
.Protect Password:="Kunde"
End With
End If
End Sub
tapa 1
taulukkovalitsimesta klikkaa haluttu taulukko ja hiiren oikealla klikkaat ko taulukon valitsimmessa ja avautuvasta valikosta View Code/Näytä koodi. Avautuvaan moduuliin sitten liität koodin...

tapa 2
taulukkopuolella näppäinyhdistelmä CTRL+F11 ja vasemmalta Projektinhallinnasta tuplaklikkaat haluamaasi taulukkomoduulia.
Varmista, että on oikea projekti laajennettuna (- merkki projektin edessä), jos siinä on + -merkki niin laajenna projekti klikkaamalla + merkkiä. Seuraavaksi pitäisi Microsoft Excel Objects olla näkyvissä ja jos ei ole niin toista ylläoleva. Nyt sieltä löytyy taulukkomoduulit tyyliin Sheet1 (Koe), missä eka on VBA koodissa käytettävä nimi, joka voidaan vaihtaa ominaisuuksista ja suluissa on taulukon nimi, joka näkyy taulukkovalitsimessa.
No nyt tuplaklikkaat sitten haluamaasi taulukkoa ja liität koodin sinne.
Kyllä koodin nyt pitäisi toimia...
olet laittanut koodin tavalliseen moduuliin, kun se pitää olla sen taulukon moduulissa, missä haluat lukutksen tapahtuban. Siis TAULUKON MODUULIIN...
oikea koodi
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A1")) Is Nothing Then
With ActiveSheet
.Unprotect Password:="Kunde"
If Range("A1") = 1 Then
Target.Locked = True
.Protect Password:="Kunde"
Else
MsgBox " Anna solun arvoksi 1"
Range("A1").Select
End If
End With
End If
End Sub
taulukon moduuliin..
poista lukitus taulukon soluista ja muuta solun nimi, salasana ja haluttu arvo sopivaksi

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A1")) Is Nothing Then
With ActiveSheet
.Unprotect Password:="Kunde"
If Range("A1") = 1 Then
Target.Locked = True
Else
MsgBox " Anna solun arvoksi 1"
End If
.Protect Password:="Kunde"
End With
End If
End Sub
moduuliin...
liitä koodi nappiin
muuta taulukoiden nimet sopiviksi

Public Sub EtsiErot()
Dim solu As Range
On Error Resume Next
Application.ScreenUpdating = False
Worksheets("Sheet3").Cells.Clear
For Each solu In Worksheets("Sheet1").UsedRange
If Not solu = Worksheets("Sheet2").Cells(solu.Row, solu.Column) Then
Worksheets("Sheet3").Cells(solu.Row, solu.Column) = "virhe"
End If
Next
For Each solu In Worksheets("Sheet2").UsedRange
If Not solu = Worksheets("Sheet1").Cells(solu.Row, solu.Column) Then
Worksheets("Sheet3").Cells(solu.Row, solu.Column) = "virhe"
End If
Next
Worksheets("Sheet3").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub
moduuliin...
muuta nimi sopivaksi

Sub Auto_Open()
Worksheets("Taul1"). Activate
End Sub
moduuliin...

Sub SuodataJaTeeKaavio()
Dim dAlku As Date
Dim dLoppu As Date
Dim lAlku As Long
Dim lLoppu As Long
Dim Näytä As String
Dim vika As Integer
Dim kaavio As ChartObject
Dim Kaaviot As ChartObjects
On Error Resume Next
Application.ScreenUpdating = False
Worksheets("Sheet2").Activate
For Each kaavio In ActiveSheet.ChartObjects
kaavio.Select
kaavio.Delete
Next
Columns("A:B").Clear
Näytä = Range("F1")
If IsDate(Range("D1")) Then
dAlku = Range("D1")
dAlku = DateSerial(Year(dAlku), Month(dAlku), Day(dAlku))
lAlku = dAlku
End If
If IsDate(Range("E1")) Then
dLoppu = Range("E1")
dLoppu = DateSerial(Year(dLoppu), Month(dLoppu), Day(dLoppu))
lLoppu = dLoppu
End If
Worksheets("Sheet1").Activate
With Sheet1
.AutoFilterMode = False
.Range("A:D").AutoFilter
.Range("A:D").AutoFilter Field:=1, Criteria1:=">=" & lAlku, Operator:=xlAnd, Criteria2:="
moduuliin...
ja liitä koodi nappiin

muuttele nimet sopiviksi ja nauhoita makro , jolla saat oikean kaaviotyypin...
nyt
sheet2 solut D(alkupvm),E(loppupvm),F(mikä sarake näytetään) syöttösoluina ja tiedot sheet1 sarakkeet A-D
moduuliin...
ja muuttele taulukoiden nimet sopiviksi

Option Explicit

Sub Siirrä()
Dim Alue As Range
Dim Kotikunta As Range
Dim Solu As Range
Dim haku As Variant
Dim vika As Integer
On Error Resume Next
Application.ScreenUpdating = False
Worksheets("Sheet2").Activate
vika = Range("A65536").End(xlUp).Row
For Each Solu In Range("A2:A" & vika)
Set Alue = EtsiJaSiirrä(Solu, Range("Sheet1!A:A")).EntireRow
Set Kotikunta = EtsiJaSiirrä(Solu.Offset(0, 1), Alue)
If Not Kotikunta Is Nothing Then
Solu.Offset(0, 2) = 1
Else
Solu.Offset(0, 2) = 0
End If
Next
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
Worksheets("Sheet2").Activate
End Function
taulukko2 moduuliin napille koodi

Private Sub CommandButton1_Click()
Siirrä
End Sub

moduuliin...
Option Explicit

Sub Siirrä()
Dim Löydetty As Range
Dim haku As Date
On Error Resume Next
Application.ScreenUpdating = False
Worksheets("Sheet2").Activate
Range("A3:A1000").EntireRow.Clear
haku = CDate(Range("A1"))
Set Löydetty = EtsiJaSiirrä(haku, Range("Sheet1!A:A")).EntireRow
Union(Löydetty, Löydetty).Copy Range("Sheet2!A3")
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
Worksheets("Sheet2").Activate
End Function

muuttele nimet sopiviksi
kuten Yucca mainitsi niin automaattinen tekstin korjaus

http://office.microsoft.com/fi-fi/word/CH060831681035.aspx
olen käyttänyt vastaavaa ohjelmoinnissa. Helppoa laittaa ryhmittäin($) sanomat(lauseet) ja helppo hakea tiedostosta. Tietenkin sen voi tehdä pyytämälläsi tavalla, mutta mielestäni tämä on mukavin ja selkein tapa.

tee tiedosto C:\lauseet.txt" muotoon

$10 'aihe1
kunde testaa1
kunde testaa2
kunde testaa3
$20 'aihe2
kunde testaa11
kunde testaa21
$30 'aihe3
kunde testaa111
kunde testaa211
kunde testaa311
kunde testaa411
kunde testaa511

ja liitä koodi ThisDocument moduuliin...

kysyy aiheen numeron esim. 20 ja sitten rivinumeron esim. 2 ja kirjoittaa aktiiviseen kohtaan tekstin "kunde testaa21"

Dim Aihe As Variant
On Error Resume Next
Aihe = InputBox("Anna aiheen numero")
If Aihe = "" Then Exit Sub
Tekstirivi = InputBox("Anna rivinumero")
If Tekstirivi = "" Then Exit Sub
Selection.TypeText LueTeksti("C:\lauseet.txt", Aihe, Tekstirivi)
End Sub
Function LueTeksti(strTextFile As String, strDollari As Variant, lngTxtLine As Variant) As Variant

Dim dollari As String
Dim Tekstirivi As String
Dim Rivinumero As Long
Dim Dollaritesti As Boolean
Dim Pituus As Long
Dim Tarkistus As Long
Dim Oma As Long


On Error GoTo VIRHE
dollari = "*$" & strDollari & "*"
Open strTextFile For Input As #1

Do While Not EOF(1)
Line Input #1, Tekstirivi
If Tekstirivi Like dollari Then
Dollaritesti = True
Rivinumero = 0
End If

If Dollaritesti = True Then
If Rivinumero = lngTxtLine Then
Oma = InStr(1, Tekstirivi, (Chr(39)))
If Oma > 0 Then
Pituus = Len(Tekstirivi)
Tarkistus = InStr(1, Tekstirivi, (Chr(39)))
If Tarkistus > 0 Then
LueTeksti = Mid(Tekstirivi, 1, (Tarkistus - 2))
If LueTeksti = "False" Or LueTeksti = "True" Then
LueTeksti = CBool(LueTeksti)
Exit Do
ElseIf IsNumeric(LueTeksti) = True Then
LueTeksti = CDbl(LueTeksti)
Exit Do
Else
LueTeksti = CStr(LueTeksti)
Exit Do
End If
End If
ElseIf Oma = 0 Then
LueTeksti = Tekstirivi
If LueTeksti = "False" Or LueTeksti = "True" Then
LueTeksti = CBool(LueTeksti)
Exit Do
ElseIf IsNumeric(LueTeksti) = True Then
LueTeksti = CDbl(LueTeksti)
Exit Do
Else
LueTeksti = CStr(LueTeksti)
Exit Do
End If
End If
End If
Rivinumero = Rivinumero + 1
End If
Loop
Close #1
POISTU:
If LueTeksti = Empty Then MsgBox "Annettua riviä ei löydy!!!", vbCritical
Exit Function
VIRHE:
Close #1
MsgBox "Joku meni pieleen!!!", vbCritical
Resume POISTU
End Function


Keep Excelling (Wording)
@Kunde

P.S. seuraavaksi varmaan haluatkin tiedot lomakkeelle, josta klikkaamalla sitten suoraan tekstiin... :-)
53 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt