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
poista ensiksi taulukosta (nyt Sheet1) kaikkien solujen lukitus ja suojaa VBA projekti salasanalla. Tallenna sitten työkirja normaalisti ja siinäpä se...

oletuksena, että A sarakkeeseen tulee aina tieto, muuta sopivaksi

ThisWorkbook moduuliin...

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim vika As Integer
On Error Resume Next
Sheets("Sheet1").Unprotect Password:="Kunde"
vika = Range("A65536").End(xlUp).Row
Range("A1:A" & vika).EntireRow.Locked = True
Sheets("Sheet1").Protect Password:="Kunde"
End Sub
ei voi tehdä pelkillä kaavoilla, joten on käytettävä koodia...
koodi toimii siten, että kun taulukko1:ssä joku tieto muuttuu tarkistetaan löytyykö TRUE. Jos löytyi piilotetaan sarakkeet, muuten poistetaan piilotus.
pikkumuutoksilla voi esim. tyhjentää solujen arvot
muuttele alueita sopivaksi

taulukon moduuliin

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
HaeJaPiilota
End Sub

moduuliin...

Function HaeJaPiilota()
Dim solu As Range
With Sheets("Sheet1").Cells
Set solu = .Find( _
What:=True, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
End With


If Not solu Is Nothing Then
Sheets("Sheet2").Columns("F:G").EntireColumn.Hidden = True
Else
Sheets("Sheet2").Columns("F:G").EntireColumn.Hidden = False
End If

End Function
kyseessä ihan perusjuttu ja muutama kaava

A1=P
B1=U
C1=I
D1=R

soluihin A2:D2 syötetään 2 arvoa...
tulos soluihin A3:D3

en jaksanut tarkistella kaavoja...

moduuliin...

Public Function IPR(P As Double, R As Double) As Double
IPR = Sqr(P / R)
End Function
Public Function PUI(U As Double, I As Double) As Double
PUI = U * I
End Function
Public Function PUR(U As Double, R As Double) As Double
PUR = U * U / R
End Function
Public Function PIR(I As Double, R As Double) As Double
PIR = I * I * R
End Function

Public Function UPR(P As Double, R As Double) As Double
UPR = Sqr(P * R)
End Function
Public Function UIR(I As Double, R As Double) As Double
UIR = I * R
End Function
Public Function RUI(U As Double, I As Double) As Double
RUI = U / I
End Function
Public Function RPI(P As Double, I As Double) As Double
RPI = P / (I * I)
End Function
Public Function RPU(P As Double, U As Double) As Double
RPU = P * U * U
End Function

taulukon moduuliin...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False

If Not Range("A2") = "" And Not Range("D2") = "" Then
Range("A3:D3") = ""
Range("C3").Value = IPR(Range("A2"), Range("D2"))
Range("B3").Value = UPR(Range("A2"), Range("D2"))
Range("A3") = Range("A2")
Range("D3") = Range("D2")
Range("A2:D2") = ""
End If

If Not Range("B2") = "" And Not Range("C2") = "" Then
Range("A3:D3") = ""
Range("A3").Value = PUI(Range("B2"), Range("C2"))
Range("D3").Value = RUI(Range("B2"), Range("C2"))
Range("B3") = Range("B2")
Range("C3") = Range("C2")
Range("A2:D2") = ""
End If

If Not Range("B2") = "" And Not Range("D2") = "" Then
Range("A3:D3") = ""
Range("A3").Value = PUR(Range("B2"), Range("D2"))
Range("B3") = Range("B2")
Range("D3") = Range("D2")
Range("A2:D2") = ""
End If

If Not Range("C2") = "" And Not Range("D2") = "" Then
Range("A3:D3") = ""
Range("A3").Value = PIR(Range("C2"), Range("D2"))
Range("B3").Value = UIR(Range("C2"), Range("D2"))
Range("C3") = Range("C2")
Range("D3") = Range("D2")
Range("A2:D2") = ""
End If

If Not Range("C2") = "" And Not Range("D2") = "" Then
Range("A3:D3") = ""
Range("A3").Value = PIR(Range("C2"), Range("D2"))
Range("C3") = Range("C2")
Range("D3") = Range("D2")
Range("A2:D2") = ""
End If

If Not Range("C2") = "" And Not Range("D2") = "" Then
Range("A3:D3") = ""
Range("A3").Value = PIR(Range("C2"), Range("D2"))
Range("C3") = Range("C2")
Range("D3") = Range("D2")
Range("A2:D2") = ""
End If

If Not Range("A2") = "" And Not Range("D2") = "" Then
Range("A3:D3") = ""
Range("B3").Value = UPR(Range("A2"), Range("D2"))
Range("A3") = Range("A2")
Range("D3") = Range("D2")
Range("A2:D2") = ""
End If



If Not Range("A2") = "" And Not Range("C2") = "" Then
Range("A3:D3") = ""
Range("D3").Value = RPI(Range("A2"), Range("C2"))
Range("A3") = Range("A2")
Range("C3") = Range("C2")
Range("A2:D2") = ""
End If

If Not Range("A2") = "" And Not Range("B2") = "" Then
Range("A3:D3") = ""
Range("D3").Value = RPU(Range("A2"), Range("B2"))
Range("A3") = Range("A2")
Range("B3") = Range("B2")
Range("A2:D2") = ""
End If
If Application.WorksheetFunction.CountA(Range("A2:D2")) = 2 Then
Range("A3:D3") = ""
End If
Application.EnableEvents = True
End Sub
Sub Resetoi()
Application.EnableEvents = True
End Sub
nyt desimaalitkin mukana ;-)

Sub koe()
Dim Lähdealue2 As Range
Dim vika2 As Integer

vika2 = Range("D65536").End(xlUp).Row
Set Lähdealue2 = Range("D5:D" & vika2)
For Each solu In Lähdealue2
Select Case solu
Case Is > 0
solu.Offset(0, 7) = CDbl(Range("G7")) + CDbl(solu) + CDbl(Range("I1"))
Case Is < 0
solu.Offset(0, 7) = CDbl(Range("G7")) - CDbl(solu) - CDbl(Range("I1"))
Case 0
solu.Offset(0, 7) = CDbl(Range("G7"))
End Select
Next
End Sub
joo kyllä Kunden portaali aukeaa virallisestikin kevään aikana. Varmuuskopiot serveriltä vaan menivät "vituiksi" ja joudun manuaalisesti tekeen juttuja uusiksi. Portaaliin tulee aluksi osiot CAD/CAM/CNC, EXCEL(myöhemmin muut officejutskat) ja MATKAILU lähinnä nyt THAIMAA (Khorat ja Pattaya). Varsinkin CAD/CAM/CNC osaajat voisivat lähettää mulle mailia [email protected]

KEEP EXCELING
Kunde
kyllä se siitä treenaamalla...

Sub koe()
Dim Lähdealue2 As Range
Dim vika2 As Integer

vika2 = Range("D65536").End(xlUp).Row
Set Lähdealue2 = Range("D5:D" & vika2)
For Each solu In Lähdealue2
Select Case solu
Case Is > 0
solu.Offset(0, 7) = Val(Range("G7")) + Val(solu) + Val(Range("I1"))
Case Is < 0
solu.Offset(0, 7) = Val(Range("G7")) - Val(solu) - Val(Range("I1"))
Case 0
solu.Offset(0, 7) = Val(Range("G7"))
End Select
Next
End Sub
voithan koodilla poistaa suojauksen lajittelun ajaksi ja sitten suojata taulukon taas esim.

Worksheets("Sheet1").Unprotect Password:="kunde"
lajittelukoodi tähän
...
Worksheets("Sheet1").Protect Password:="kunde"
ei toimi 97 versiossa. 2000 versiosta lähtien ton pitäs muistaakseni toimia ja uudemmissa versioissahan on noita lukituksen poistoja sitten lisäilty enemmänkin, joten sorry!
siinä missä laitat suojauksen koodissa lisäät vaan seuraavan

UserInterfaceOnly:=True eli esim.

Worksheets("Sheet1").Protect Password:="kunde", UserInterfaceOnly:=True

et tarvitse sitten enää tuota riviäkään... ActiveWorkbook.Worksheets(2).EnableAutoFilter = True
originelli oli näin, ja siinä on toi "Alue", jonka määrittelet valikosta lisää/nimi/määritä Insert/Name/Define ja siinä valitset haluamasi solut ja annat alueelle nimeksi Alue. Näin sen ajattelin...
Ok voit muuttaa koodia siten, että korvaat
For Each solu In Range("Alue") tällä
For Each solu In Range("A2:A6000") ja käyt sitten koodissa muuttamassa aluetta.
Tietenkin voit tehdä niin, että valinta on alueena, niin ei tartte kuin valita testattavat solut ja suorittaa koodi
esim.

Sub PoistaTuplat()
Dim solu As Range
Dim Vika As Double
On Error GoTo virhe
For Each solu In Selection
If Not IsEmpty(solu) Then
EiTupla.Add solu.Value, CStr(solu.Value)
End If
Next solu
Exit Sub
virhe:
Resume Next
End Sub
"Esim. Poistan sieltä kaikki paitsi yhden solun. Kun ajan värjäys_makron uudestaan, niin värjää makro samat solut kuin aikaisemmalla kerralla. Ihan ku makro hakisi tiedot jostain muistista, eikä siltä Sheet2 alueelta."

nimeä taulukko2 verrattavat solut ="Alue"
et ole nimennyt haettavia soluja uudelleen.

"poistan värjäykset kokonaan Sheet1 taulukosta"

Makrohan poistaa värjäykset automaattisesti Sheet1:stä.Joten ei tartte tehdä...

eli...
Nimeä vain ne solut mitä vertaat ="Alue" ja toimii just niinkuin pitääkin...
vähän oli ylimalkainen kyssäri tiedoilta, mutta tolla alkuun
moduuliin...

nimeä taulukko2 verrattavat solut ="Alue" ja muokkaa taulukoiden nimet sopiviksi

Option Explicit
Dim EiTupla As New Collection

Sub Värjää()
Dim Tiedot As Variant
Dim Alue As Range
Dim i As Integer
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Sheet2").Activate
PoistaTuplat
Worksheets("Sheet1").Cells.Interior.ColorIndex = xlNone
For i = 1 To EiTupla.Count
Set Alue = EtsiJaSiirrä(EiTupla(i), Worksheets("Sheet1").Cells)
Alue.Interior.ColorIndex = 3
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub PoistaTuplat()
Dim solu As Range
Dim Vika As Double
On Error GoTo virhe
For Each solu In Range("Alue")
If Not IsEmpty(solu) Then
EiTupla.Add solu.Value, CStr(solu.Value)
End If
Next solu
Exit Sub
virhe:
Resume Next
End Sub

Function EtsiJaSiirrä(Haettava As Variant, _
Hakualue As Range) As Range

Dim solu As Range
Dim ekaosoite As String

With Hakualue
Set solu = .Find( _
What:=Haettava, _
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
haluamasi taulukon moduuliin...
muuta Arrayssa olevien taulukoiden nimiä sopiviksi

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheets(Array "Sheet1", "Sheet2", "Sheet3")).Select
End Sub
moduuliin...
muuttele taulukoiden nimet sopiviksi

Option Explicit
Dim EiTupla As New Collection
Sub Kopioi()
Dim Tiedot As Variant
Dim Alue As Range
Dim i As Integer
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Sheet1").Activate
Worksheets("Sheet2").Cells.Clear
PoistaTuplat
For i = 1 To EiTupla.Count
Set Alue = EtsiJaSiirrä(EiTupla(i), Columns("A")).Offset(0, 1)
Tiedot = Alue
Tiedot = Application.WorksheetFunction.Transpose(Tiedot)
Range("Sheet2!A" & i) = EiTupla(i)
Range("Sheet2!B" & i).Resize(Alue.Columns.Count, Alue.Rows.Count) = Tiedot
Next i
Worksheets("Sheet2").Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub PoistaTuplat()
Dim solu As Range
Dim Vika As Double
On Error GoTo virhe
Vika = Range("A65536").End(xlUp).Row
For Each solu In Range("A1:A" & Vika)
If Not IsEmpty(solu) Then
EiTupla.Add solu.Value, CStr(solu.Value)
End If
Next solu
Exit Sub
virhe:
Resume Next
End Sub
Function EtsiJaSiirrä(Haettava As Variant, _
Hakualue As Range) As Range

Dim solu As Range
Dim ekaosoite As String

With Hakualue
Set solu = .Find( _
What:=Haettava, _
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
kysyttiin...
"siirtää tiedot seuraavalla sheetillä olevaan taulukkoon ensimmäiselle riville (siirtäen aiempia rivejä vastaavasti alaspäin)"

vastasit
yksinkertainen niin mikset käytä XL:n valmista Data->form toimintoa

mitenkäs tolla siirrät seuraavalle sivulle ja siirrät tiedon aina ekalle riville ja päivität muita alaspäin???
Kerro meille kuinka se tapahtuu ehdottamallasi valmiilla toiminnolla, kun en saa sitä toiminaan kysymyksessä esitetyllä tavalla...

Makro= piece of cake
soluun kaavana esim. =Palkka(A1)

moduuliin...

Public Function Palkka(Palkkaluokka As Integer) As Integer
Select Case Palkkaluokka
Case 1
Palkka = 9
Case 2
Palkka = 10
Case 3
Palkka = 11
Case 4
Palkka = 12
Case 5
Palkka = 13
Case Else
Palkka = 0
End Select
End Function
Sub UusiVuosi()
Range("A1")=2009
End Sub

;-)
uusi vuosi ja uudet kujeet
jälleen grillataan (nyt aamulla +22 C (klo 7), joten kaiketi tarkenen...)
Keep Exceling
@Kunde
=INDIRECT("A"&ROW())*2
muuta kaavat
=INDIRECT("A1")*2 tai lontoon kielelllä
=EPÄSUORA("A1")*2 jne...
55 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt