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
moduuliin..
Sub Täytä()
Dim vika As Integer
vika = Range("D65536").End(xlUp).Row - 1
Range("D18").Formula = "=D17+1"
Range("D18").AutoFill Range("D18:D" & vika)
End Sub
moduuliin...
Sub Avaa()
Workbooks.Open ThisWorkbook.Path & "\taulukko2.xls"
End Sub
vaikea vastata kun kysymys niin yöimalkainen, mutta kaavan täyttö onnistuu seuraavasti
esim. kaavat soluihin D18:D50...



Range("D18").Formula = "=D17+1"
Range("D18").AutoFill Range("D18:D50")
kyllä toi toimii ihan ok, jos excelissä VBA koodia väsäät-jos VB:llä niin sitten eri juttu.

Private Sub CommandButton1_Click()
Range("B:B,C:C,D:D,E:E,F:F,H:H,J:J,K:K,L:L").Select
End Sub


voit kokeilla lisätä koodiin taulukon aktivoinnin niin silloin ainakin toimii...

esim.
Private Sub CommandButton1_Click()
Worksheets("Sheet1").Activate
Range("B:B,C:C,D:D,E:E,F:F,H:H,J:J,K:K,L:L").Select
End Sub
excelin taukukon painikkeeseen koodi

Private Sub CommandButton1_Click()
UserForm1.Show
End Sub

lisää VBA puolella userform ja siihen komentopainike ja tekstiruutu. Tekstiruudun ominaisuuksissa, Password kohtaan laita haluamasi merkki jota toistetaan normaalistihan se on * ...


lomakkeelle koodi

Private Sub CommandButton1_Click()

If TextBox1 = "passu" Then
Sheets("1").Visible = True
Sheets("2").Visible = True
Sheets("1").Select
Else
MsgBox "Password incorrect!"
Exit Sub
End If
End Sub
ei oikein onnaa fiksusti ilman APIa, mutta testailin SendKeys komennoilla kikkailla ja toimii se silläkin ihan jees ;-)


Excelissä Tools/Macro/Security Trusted Publisher välilehdeltä pitää laittaa ruksi kohtaan Trust Access to Visual Basic Project

ja originaalissa pitää olla viittaus VBA puolella referenssiin Microsoft Visual Basic for Applications Extensibility 5.3
moduuliin...

Sub TallennaSanasanalla()
päivä = 25
kuukausi = 11
vuosi = 2008
tiedostonimi = "b"
Sheets(Array("1", "2", "3")).Copy
With Application

.VBE.CommandBars("Menu Bar").Controls("Tools") _
.Controls("VBAProject Properties...").Execute

.SendKeys "^{TAB}"

.SendKeys "{ }"

.SendKeys "{TAB}" & "kunde"

.SendKeys "{TAB}" & "kunde"

.SendKeys "{TAB}"

.SendKeys "{ENTER}"
End With
ActiveWorkbook.SaveAs Filename:="C:\" & vuosi & "_" & kuukausi & "_" & päivä & "_" & tiedostonimi & ".xls"
ActiveWorkbook.Close
End Sub

Keep Excelling
@Kunde
originaalissa valitse haluamasi kuukausi välilehdeltä sarakkeesta A se päivämäärä, jonka rivitiedot haluat siirtää osastojen työkirjoihin

moduuliin...

Sub Siirrä()
Dim Päivä As Integer
Dim Kuukausi As String
Dim Vuosi As Integer
Dim Haku As String
Dim Myynti As Double
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If ActiveCell = "" Then
MsgBox "Valitsemasi solu on tyhjä!"
Exit Sub
End If
Päivä = ActiveCell
'MUUTA TEKSTI JOS TAULUKKO EI OLE NIMETTY TAMMIKUU, HELMIKUU...
'JOS TAMMI, HELMI... NIIN MUUTA TAMMI, HELMI...
Select Case UCase(ActiveSheet.Name)
Case "TAMMIKUU"
Kuukausi = 1
Case "HELMIKUU"
Kuukausi = 2
Case "MAALISKUU"
Kuukausi = 3
Case "HUHTIKUU"
Kuukausi = 4
Case "TOUKOKUU"
Kuukausi = 5
Case "KESÄKUU"
Kuukausi = 6
Case "HEINÄKUU"
Kuukausi = 7
Case "ELOKUU"
Kuukausi = 8
Case "SYYSKUU"
Kuukausi = 6
Case "LOKAKUU"
Kuukausi = 7
Case "MARRASKUU"
Kuukausi = 8
End Select
'MUUTA TARVITTAESSA
Vuosi = 2008

'MUUTA työkirjojen nimet b,c,d...
'B SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 1)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "b"


'C SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 2)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "c"


'D SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 3)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "d"


'E SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 4)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "e"


'F SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 5)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "f"


'G SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 6)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "g"


'H SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 7)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "h"


'I SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 8)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "i"


'J SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 9)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "j"


'K SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 10)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "k"


'L SARAKKEEN OSASTO
Myynti = ActiveCell.Offset(0, 11)
Haku = Päivä & "." & Kuukausi & "." & Vuosi
EtsiJaSiirrä Haku, Myynti, "l"

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Function EtsiJaSiirrä(Päiväys As String, Tieto As Double, Osasto As String) As Range
Dim Solu As Range
Dim Työkirja As Workbook
Päiväys = Format(Päiväys, "Short Date")
On Error Resume Next
'MUUTA POLKU
Set wb = Workbooks.Open("C:\Documents and Settings\Kunde\Omat tiedostot\" & Osasto & ".xls", False, False)
wb.Sheets(1).Activate
Set Solu = Cells.Find(What:=CDate(Päiväys), After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Range(Solu.Address).Offset(0, 1) = Tieto
On Error GoTo 0
wb.Close True
End Function

Keep Excelling
@Kunde
http://www.bmsltd.co.uk/Excel/Default.htm
ja lataa sieltä FormFun.zip
taulukon moduuliin...
ja solussa A3 =Summa (A1:A2)


Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Range("A4") = "" And Not Range("A1") = "" And Not Range("A2") = "" Then
Range("A4") = Range("A3")
End If
End Sub
moduuliin...

Function Etsi(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With Range("D2:D22")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
EkaOsoite = solu.Address
Do
Set Etsi = Union(Etsi, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With

End Function

Sub Testi()
Dim Löydetty As Range
Dim Haku As Variant

On Error GoTo virhe
Haku = "x"
Set Löydetty = Etsi(Haku)
MsgBox Union(Löydetty, Löydetty).Address
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub
mun viesteissä tarkoittaa

taulukon moduuliin...

taulukon valitsemasta klikkaat hiiren oikealla ja klikkaat Näytä koodi/View Code ja seuraavaksi aukeaa VBA editorissa taulukon moduuli mihin liität koodin tai

excelin puolella ALT+F11 ja aukeaa VBA editori ja ja vasemmalta VBAProject "työkirjan nimi" tuplaklikkaat taulukon nimeä mihin koodin haluat liittää
jos VBAProject ikkuna ei ole näkyvissä sen saat näkyviin valikosta View/Project Explorer tai CTRL+R

moduuliin...
valikosta Insert/Module ja liität koodin aukeavaan moduuliin

Class moduuliin...

valikosta Insert/Class Module ja liität koodin aukeavaan moduuliin

sun tapauksessa nyt toi eka taulukkokoodi on tavallisessa moduulissa eikä taulukon moduulissa, joten ei voi toimia...

siirrä se siis sinne taulukon moduuliin
Mulla Excel 2003 ja piippaa ihan kivasti.
siis taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" And Target.Value = 0 Then
PlayWAV
End If
End Sub

ja moduuliin ...

Private Declare Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long

Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

Sub PlayWAV()
WAVFile = "beep.wav"
WAVFile = ThisWorkbook.Path & "\" & WAVFile
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
End Sub
http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000038800866
koodillakaan.
Viimeksi muutetun solun merkkien määrän saa esim. tilariville allaolevalla koodinpätkällä

taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.StatusBar = Len(Target)
End Sub
velhon avulla, mutta klikkaamalla objektia suunnittelutilassa aukeaa taulukon moduuli ja siellä esim. jos lisätty komentopainike

Private Sub CommandButton1_Click()
End Sub

lisäämällä nyt sen makron tohon proseduuriin toimii ihan jees (Makro pitää olla hmm?- miten ton nyt sanois oikein, uudessa moduulissa(Insert/Module)- ei siis taulukoiden eikä ThisWorkbook moduuleissa )...

Private Sub CommandButton1_Click()
Näytä
End Sub

ja moduulissa esim.

Sub Näytä()
MsgBox "hei"
End Sub

@Kunde
koodin alkuun Application.DisplayAlerts = False
ja loppuun Application.DisplayAlerts = True

muista sitten varmistaa, että jos virhe ilmenee niin virheenkorjauksessa asetat
Application.DisplayAlerts = True tai jos ei ole mitään virheen tsekkausta, niin ainakin alkuun laitat sitten On Error Resume Next
ei toimi ei toimi kun taulukko on piilotettu. Tietenkin voit koodilla laittaa sen näkyville ennen kopiointia ja sitten piilottaa kun tarvittavat jutut tehty

esim.

Application.ScreenUpdating = False
Sheets("Data").Visible = xlSheetVisible
Sheets("Data").Select
'koodia
Sheets("Data").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True

mutta...
toimii se näinkin ilman kikkailuja ;-)

Sheets("Data").Range("A1:A10").Copy Destination:=Sheet2.Range("A1")

@Kunde
moduuliin...
tiedot nyt A1:B jotakin
tulos näkyviin F1 alkaen

Sub PoistaTuplat()
Dim cell As Range
Dim Vika As Double
Dim EiTupla As New Collection
On Error GoTo virhe

Vika = Range("A65536").End(xlUp).Row

'kopioidaan tiedot F1 alkaen
Columns("F:G").Clear
Range("A1:B" & Vika).Copy Destination:=Range("F2")

'lajitellaan
Range("F2:G" & Vika).Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("G2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal

'lisätään uniikit arvot kokoelmaan
For Each cell In Range("F2:F" & Vika + 1)
If Not IsEmpty(cell) Then
EiTupla.Add cell.Value, CStr(cell.Value & cell.Offset(0, 1).Value)
End If
Next cell
'tyhjennetään alue ja lisätään riviotsikot
Columns("F:G").Clear
Range("F1") = "TULOKSET"
Range("G1") = "MÄÄRÄ"

'täytetään tiedot
'eka kirjain kokoelmasta
Range("F2").Select
ActiveCell = EiTupla(1)

'lisätään loput
For i = 1 To EiTupla.Count
If ActiveCell = EiTupla(i) Then
ActiveCell.Offset(0, 1) = ActiveCell.Offset(0, 1) + 1
Else
ActiveCell.Offset(1, 0).Select
ActiveCell = EiTupla(i)
ActiveCell.Offset(0, 1) = ActiveCell.Offset(0, 1) + 1
End If
Next
'sarakelevys kohdilleen
Range("F1:G1").EntireColumn.AutoFit
Exit Sub
virhe:
'tänne tullaan, jos arvo oli jo kokoelmassa... jatketaan vaan lisäystä seuraavilla arvolla
Resume Next
End Sub
riippuu mistä valikosta olet sen napin väsännyt... mutta koodilla esim. noin

objektin nimi.Caption=Range("A1")
suojaa VBA projekti salasanalla ja VBA puolelta pistä Data välilehden visible arvoksi=0 xlSheetHidden. Tällöin ei tartte koodia rukkailla, eli ei tartte Unprotect ja Protect juttujen kanssa painia
@Kunde
57 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt