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
tarpeet vaihtui toiseksi alkuperäisestä, mutta eipä murehdita sitä...

moduuliin...
Sub Auto_Open()
Worksheets("Sheet1").Range("D6:L6").Interior.ColorIndex = 56
End Sub

ja kyseessäolevan TAULUKON MODUULIIN...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Range("D6:L6").Interior.ColorIndex = 56
End Sub

Keep EXCELing
@Kunde
et ole määritellyt LN254 labelia, johon viittaat GoTo rivillä...

On Error Resume Next
If ActiveSheet.Range("B22") = "" Then
GoTo LN254 'tästä hyppy
On Error GoTo 0
End If
'koodia...
LN254:
' tänne tullaan GoTo LN254 riviltä
MsgBox "tänne tultiin!"
Ookos koskaan kokeillut makronauhoitinta?
Tommosta se aikaan...
Sub Macro1()
'
' Macro2 Macro
' Macro recorded 2.3.2011 by kunre
'

'
Range("D6:L6").Select
Selection.Interior.ColorIndex = 56
End Sub

toki sitä voi kaunistella ja poistella yleensä 80-90% turhaa skeidaa ja saada se helpommin luettavaksi ja paremmin toimivaksi...

Sub Macro1()
Range("D6:L6").Interior.ColorIndex = 56
End Sub

Keep EXCELing
@Kunde
Pikku viilausta ....


Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A11:A12")) Is Nothing Then
Target = UCase(Target)
End If
If Not Intersect(Target, Range("A13: A14")) Is Nothing Then
Target = StrConv(Target, vbProperCase)
End If
End Sub


Keep EXCELing
@Kunde
Sorry mun webbisivut päivittämättä muitten kiireiden takia. Yritän saada ne ajan tasalle keväämmällä ilmoittelen sitten...
ko. taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A11")) Is Nothing Then
Range("A11") = UCase(Range("A11"))
End If
If Not Intersect(Target, Range("A12")) Is Nothing Then
Range("A12") = StrConv(Range("A12"), vbProperCase)
End If
End Sub


Keep EXCELing
@Kunde
jos solussa A13 on kelpoisuusehtona lista, jossa 2 jäsentä Avoinna ja Suljettu
Koodin pätkä Range("A11:A13").ClearContents tai Range("A11:C13") = "" tyhjentää solut
Ja kun solua A13 klikkaa niin valinnat(Avoinna ja Suljettu) on käytössä.

Mitenkäs se "lista" on tehty soluun A13?

Keep EXCELing
@Kunde
en tajunnut pätkääkään...
"nuo ~- merkit on soluissa (ei kylläkään välilyöti...) voit ne poistaa lisäämällä koodiin replace funktion millä korvaat ~- merkit välilyönneiksi
esim. Replace(Suodatin, "~", " ")"

Function Pikasuodatus(Alue As Range) As String
Dim Suodatin As String
Suodatin = ""
On Error GoTo Poistu
Application.Volatile True
With Alue.Parent.AutoFilter
If Not Intersect(Alue, .Range) Is Nothing Then
With .Filters(Alue.Column - .Range.Column + 1)
If .On Then
Suodatin = Mid(.Criteria1, 2)
Select Case .Operator
Case xlAnd
Suodatin = Mid(Suodatin & " JA " & .Criteria2, 2)
Case xlOr
Suodatin = Mid(Suodatin & " TAI " & .Criteria2, 2)
End Select

Else
Suodatin = "KAIKKI"
End If
End With
End If
End With
Poistu:
Pikasuodatus = Replace(Suodatin, "~", " ")
End Function

Keep EXCELing
@Kunde
Function Pikasuodatus(Alue As Range) As String
Dim Suodatin As String
Suodatin = ""
On Error GoTo Poistu
Application.Volatile True
With Alue.Parent.AutoFilter
If Not Intersect(Alue, .Range) Is Nothing Then
With .Filters(Alue.Column - .Range.Column + 1)
If .On Then
Suodatin = Mid(.Criteria1, 2)
Select Case .Operator
Case xlAnd
Suodatin = Mid(Suodatin & " JA " & .Criteria2, 2)
Case xlOr
Suodatin = Mid(Suodatin & " TAI " & .Criteria2, 2)
End Select

Else
Suodatin = "KAIKKI"
End If
End With
End If
End With
Poistu:
Pikasuodatus = Suodatin
End Function

"Myös välilyönnin kohdalle tulevat aaltoviivat ~ eivät ole toivottuja. Saako niitä poistettua? (esim d18 solun näkymä. =yy12 tai =yy12~)"

nuo ~- merkit on soluissa (ei kylläkään välilyöti...) voit ne poistaa lisäämällä koodiin replace funktion millä korvaat ~- merkit välilyönneiksi
esim. Replace(Suodatin, "~", " ")

Keep EXCELing
@Kunde
toki tolla kaavalla saa muittenkin sarakkeiden suodatusehdot esille esim. viitaten edelliseen postaukseeni =Pikasuodatus(B2) näyttää sarakkeem B suodatusehdot....

Keep EXCELing
@Kunde
ei tuo onnaa ilman koodia...
D18 soluun kaava esim. jos haluamasi sarakkeen suodatusehtovalikko on solussa C2 =Pikasuodatus(C2)
näyttää myös ja/tai ehdotkin ja jos ei ole mitään suodatusta niin KAIKKI teksti soluun D18...

moduuliin...

Function Pikasuodatus(Alue As Range) As String
Dim Suodatin As String
Suodatin = ""
On Error GoTo Poistu
Application.Volatile True
With Alue.Parent.AutoFilter
If Not Intersect(Alue, .Range) Is Nothing Then
With .Filters(Alue.Column - .Range.Column + 1)
If .On Then
Suodatin = .Criteria1
Select Case .Operator
Case xlAnd
Suodatin = Suodatin & " JA " & .Criteria2
Case xlOr
Suodatin = Suodatin & " TAI " & .Criteria2
End Select

Else
Suodatin = "KAIKKI"
End If
End With
End If
End With
Poistu:
Pikasuodatus = Suodatin
End Function

Keep EXCELing
@Kunde
jollain maksullisilla sovellutuksilla ton voi ilmeisesti tehdäkin.
Itse en ainakaan vielä ole löytänyt varmaa tapaa suojata tiedostoja. Jos teet sen makroilla, niin avatessa voit estää makrot ja suojaus on poissa. Toki voit ennen tiedoston sulkemista piilottaa kaikki taulukot ja jättää näkyville ns. etusivun ja siinä muistutuksen, että makrot on otettava käyttöön, jos et ota niin sulkee tiedoston.
Niin vielä tohon aikarajoituksen kiertoohan riittää kun siirtää sitten käyttiksen kelloa taaksepäin..., toki sitäkin vaihtoehtoa voi tutkia ja jos kelloa on rukattu taaksepäin niin ei avaa tiedostoa...
Monia kikkoja on, mutta ne kaikki on kierrettävissä melko helpostikin.
Summa summarum hiukankin normikäyttäjää ovelampi keksii keinot kyllä, millä tiedoston saa avattua
tekee aktiivisen taulukon A -sarakkeeseen listan uniikeista. Muuta polku ja tiedostojen nimet sopivaksi. Tiedostojen pitää olla muotoa testi1 ja testi2 tms.

moduuliin...

Sub UniikitTiedostosta()
Dim i As Long
Dim vika As Long
For i = 1 To 2
Workbooks.Open Filename:="c:\testi" & i & ".csv"
ActiveSheet.UsedRange.Copy
ActiveWorkbook.Close
vika = Range("A65336").End(xlUp).Row
Range("A" & vika).Select
ActiveSheet.Paste
Next i
vika = Range("A65536").End(xlUp).Row
For i = vika To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & i), Range("A" & i).Text) > 1 Then
Range("A" & i).EntireRow.Delete
End If
Next i
End Sub

Keep EXCELing
@Kunde
Application.ScreenUpdating = False
...koodia
Application.ScreenUpdating = True
Sub EtsijaKorvaa()
Dim polku As String
Dim tiedosto As Variant
Dim työkirja As Worksheet
Dim haettava As String
Dim korvattava As String
On Error GoTo virhe
haettava = ActiveSheet.Range("A1")
korvattava = ActiveSheet.Range("A2")
Application.ScreenUpdating = False
polku = "C:\Testailua\"
With Application.FileSearch
.NewSearch
.LookIn = polku
.SearchSubFolders = False
.Filename = ".xls"
If .Execute > 0 Then
For Each tiedosto In .FoundFiles
Workbooks.Open tiedosto
With ActiveWorkbook
For Each työkirja In .Worksheets
työkirja.Cells.Replace haettava, korvattava, xlWhole, , True
Next
.Close True
End With
Next
End If
End With
virhe:
Application.ScreenUpdating = True
End Sub

Keep EXCELing
@Kunde
moduuliin...
vaihda tiedostopolku ja sanat sopiviksi...

Sub EtsijaKorvaa()
Dim polku As String
Dim tiedosto As Variant
Dim työkirja As Worksheet
On Error GoTo virhe
Application.ScreenUpdating = False
polku = "C:\Testailua\"
With Application.FileSearch
.NewSearch
.LookIn = polku
.SearchSubFolders = False
.Filename = ".xls"
If .Execute > 0 Then
For Each tiedosto In .FoundFiles
Workbooks.Open tiedosto
With ActiveWorkbook
For Each työkirja In .Worksheets
työkirja.Cells.Replace Volvo", "mersu", xlWhole, , True
Next
.Close True
End With
Next
End If
End With
virhe:
Application.ScreenUpdating = True
End Sub

Keep EXCELing
@Kunde
KIITOS
The worst day with VBA is better than the best day at work!
helppoahan se nyt oli kun sai selkeät ohjeet...
fiksasin nyt vielä siten, että huomioi automaattisesti sarakkeiden määrän

Sub Transponoi()
Dim vika As Integer
Dim vika2 As Integer
Dim solu As Range
Dim i As Integer
Dim j As Integer
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
vika2 = Range("IV1").End(xlToLeft).Column
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("B2:B" & vika)
solu.Resize(1, vika2).Copy
Worksheets(taulukko.Name).Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Range("A2").Select
For i = 1 To vika - 1
Worksheets(originaali.Name).Range("B1").Resize(1, vika2).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
For i = 1 To vika - 1
For j = 1 To vika2 - 1
Worksheets(originaali.Name).Range("A" & i + 1).Copy Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0)
Next
Next
Application.CutCopyMode = False
End Sub

Keep EXCELing
@Kunde
laita esimerkki kopioitavasta datasta ja miten se pitää saada uuteen taulukkoon, helpottaa suunnattomasti ;-)
37 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt