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
taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A1")) Is Nothing Then
If IsNumeric(Target) Then
Range("B1") = Range("B1") + Range("A1")
Else
MsgBox "syottämäsi arvo ei ollut luku! "
Range("A1").Select
Exit Sub
End If
End If
End Sub
moduuliin...

Sub koe()
Dim Sivunalku As String
Dim Alue As Range
Dim i As Integer
Dim j As Integer
Dim alkuwb As String
Dim uusiwb As String
Dim Sivunvaihto As Integer
Dim Rivit As Long
Dim Polku As String
Dim Sivunkoko As Integer

On Error GoTo virhe
Application.DisplayAlerts = False
Application.ScreenUpdating = False

takaisin:
Sivunkoko = Application.InputBox(" Anna rivienmaara sivulla", "Sivuntulostus", 30, Type:=1)
If Sivunkoko = 0 Then Exit Sub
If Not Sivunkoko > 0 Then
MsgBox "Sinun on annettava 0 suurempi luku!"
GoTo takaisin
End If
Rivit = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.ResetAllPageBreaks
If Rivit > Sivunkoko Then
Sivunvaihto = Int(Rivit / Sivunkoko) + 1
For i = 1 To Sivunvaihto
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveSheet.UsedRange.Cells(Sivunkoko * i + 1, 1)
Next i
End If
alkuwb = ActiveWorkbook.Name
Sivunalku = "$A$1"

For i = 1 To ActiveSheet.HPageBreaks.Count
uusi = i
If i > 1 Then Sivunalku = ActiveSheet.HPageBreaks(i - 1).Location.Address
j = ActiveSheet.HPageBreaks(i).Location.Row - 1

Workbooks.Add
uusiwb = ActiveWorkbook.Name
Workbooks(alkuwb).Sheets(1).Range(Sivunalku & ":" & "$H$" & Trim$(Str$(j))).Copy _
Destination:=Workbooks(uusiwb).Sheets(1).Range("A1") ' oletus eka taulukko
Polku = "H:\" & uusi & ".xls" 'muuta polkua
ActiveWorkbook.SaveAs Filename:=Polku
ActiveWorkbook.Close
Windows(alkuwb).Activate

Next
' vika sivu lisattava manuaalisesti
If j < Rivit Then
uusi = uusi + 1
j = j + Sivunkoko
Sivunalku = Range(Sivunalku).Offset(Sivunkoko, 0).Address
Workbooks.Add
uusiwb = ActiveWorkbook.Name
Workbooks(alkuwb).Sheets(1).Range(Sivunalku & ":" & "$H$" & Trim$(Str$(j))).Copy _
Destination:=Workbooks(uusiwb).Sheets(1).Range("A1") ' oletus eka taulukko
Polku = "H:\" & uusi & ".xls" 'muuta polkua
ActiveWorkbook.SaveAs Filename:=Polku
ActiveWorkbook.Close
Windows(alkuwb).Activate
End If
virhe:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


keep Excelling
@Kunde
pelkillä boolean operaattoreilla ja on helppolukuisempi ja ei ole sitä jossien 7 sisäkkäissääntoä (ennen versiota 2007)

=(B3*0,25*A5*G13)*((A3>=5)*0,2+(A3>=10)*0,1+(A3>=15)*0,1+(A3>=20)*0,1+(A3>=25)*0,1)
lisää referenssi Microsoft Scripting Runtime
Dim rivi As Long
Sub Alikansiot()
Sheets("Hyperlinkit").Cells = ""
HaeAlikansiot "H:"
JaaAlikansioihin
Columns("A:IV").AutoFit
End Sub

Sub HaeAlikansiot(Kansio As String)

Dim FSO As Scripting.FileSystemObject
Dim Lähde As Scripting.Folder
Dim Alikansio As Scripting.Folder

Set FSO = New Scripting.FileSystemObject
Set Lähde = FSO.GetFolder(Kansio)
rivi = Range("A65536").End(xlUp).Row + 1
Cells(rivi, 1).Formula = Lähde.Path
Cells(rivi, 1).Hyperlinks.Add Anchor:=Cells(rivi, 1), Address:=Lähde.Path
For Each Alikansio In Lähde.SubFolders
HaeAlikansiot Alikansio.Path
Next Alikansio

Set Alikansio = Nothing

Set Lähde = Nothing
Set FSO = Nothing
End Sub

Sub JaaAlikansioihin()
Dim a As Variant
Dim i As Long
Dim j As Integer
On Error GoTo virhe
rivi = Range("A65536").End(xlUp).Row
For i = 136 To rivi
a = Split(Range("A" & i), "\")
Cells(i, 1).Hyperlinks.Add Anchor:=Cells(i, 1), Address:=Range("A2") & "\" & a(2)
For j = 1 To UBound(a)
If j >= 3 Then
Cells(i, j - -1).Hyperlinks.Add Anchor:=Cells(i, j - 1), Address:=Cells(i, j - 2) & "\" & a(j)
End If


Next
Next
virhe:
End Sub
kuten viestissä mainitaan

' lisää referenssi Microsoft Scripting Runtime
Sub Alikansiot()
Sheets("Hyperlinkit").Cells = ""
HaeAlikansiot "H:\Excel\" ' muuta kansiopolku
End Sub

et ole lisännyt viittausta
moduuliin...

' lisää referenssi Microsoft Scripting Runtime
Sub Alikansiot()
Sheets("Hyperlinkit").Cells = ""
HaeAlikansiot "H:\Excel\" ' muuta kansiopolku
End Sub

Sub HaeAlikansiot(Kansio As String)

Dim FSO As Scripting.FileSystemObject
Dim Lähde As Scripting.Folder
Dim Alikansio As Scripting.Folder
Dim rivi As Long

Set FSO = New Scripting.FileSystemObject
Set Lähde = FSO.GetFolder(Kansio)
rivi = Range("A65536").End(xlUp).Row + 1
Cells(rivi, 1).Formula = Lähde.Path
Cells(rivi, 1).Hyperlinks.Add Anchor:=Cells(rivi, 1), Address:=Lähde.Path
For Each Alikansio In Lähde.SubFolders
HaeAlikansiot Alikansio.Path
Next Alikansio
Set Alikansio = Nothing
Columns("A").AutoFit
Set Lähde = Nothing
Set FSO = Nothing
End Sub
Koska solut on yhdistetty ei suodatus toimi, koska yhdistetyissä soluissa on tietoa vain sen vasemman yläkulman solussa, joten ainoa mahdollisuus on tehdä makro.
Makrolla puretaan yhdistetyt solut ja täytetään ne ao tiedoilla, jolloin suodatus toimii...
Alla nyt simppeli esim. asiasta. Muokkaa mieleiseksi.
Nyt originaalitiedot Data nimisessä taulukossa, jonka nimi pitää muuttaa sopivaksi.
Ohjelma aluksi kysyy maanosaa ja tekee sen mukaisen suodatuksen Huuhaa(muuta mieleiseksi) taulukkoon. Sen jälkeen voit tehdä tehdä vapaasti suodatuksia eri kentille alasvetovalikoista.

Sub Pikasuodatus()
Dim Hakuehto As String
Dim Alue As Range
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set Alue = Sheets("Data").Range("A1").CurrentRegion ' vaihda nimi originaalitiedot tässä
Sheets("Huuhaa").Delete
Worksheets.Add().Name = "Huuhaa"
Alue.Copy Destination:=Sheets("Huuhaa").Range("A1")
Hakuehto = Application.InputBox("Anna maanosan nimi jonka tietoja haluat tutkia", "Hakukone", "Eurooppa", Type:=2)
Set Alue = Sheets("Huuhaa").Range("A1").CurrentRegion
With Alue
.UnMerge
.Resize(.Rows.Count, 1).SpecialCells(xlBlanks).Formula = "=R[-1]C"
Range("A1").AutoFilter Field:=1, Criteria1:=Hakuehto
End With
Range("A1").Select

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

Keep Excelling!
@Kunde
"Toki sillä mainitsemallasi suodatuksella olisi iisiä tehdä suodatus esim. antenneista ja sitten kopsata ko. lista sinne antennit-taulukkoon, mutta kun pahoin pelkään että työnantaja ei sitäkään vaivaa halua nähdä :/. "

en minäkään viitsisi pelleillä phauilla ja suodatuksilla manuaalisesti...

mutta asiaan

en tarkkaan tiedä tuotteiden koodaustasi, mutta allaoleva makro päivittää automaattisesti taulukot ja lisää uuden kun uusi tuote lisätään. Tosta on helppo muunnella tarpeittesi mukaan. Tuotteet on siis sarakkeessa A, josta uudet taulukot tehdään

Datataulukon moduuliin...

rivate Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo virhe
Application.ScreenUpdating = False
Call TeeTaulukot
virhe:
Application.ScreenUpdating = True
End Sub

ja tavalliseen moduuliin...

Sub TeeTaulukot()
Dim Tiedot As Range
Dim solu As Range
Dim Taulukko As Worksheet
Dim AloitusTaulukko As Worksheet
Dim Nimi As String


On Error Resume Next
Application.DisplayAlerts = False
Set AloitusTaulukko = ActiveSheet
AloitusTaulukko.AutoFilterMode = False
Set Tiedot = Range("A1", Range("A65536").End(xlUp))
For Each Taulukko In Worksheets
If Not Taulukko.Name = "Data" Then ' muuta datataulukon nimi sopivaksi
Taulukko.Delete
End If
Next

Worksheets.Add().Name = "HUUHAA"
With Worksheets("HUUHAA")
Tiedot.AdvancedFilter xlFilterCopy, , _
Worksheets("HUUHAA").Range("A1"), True
Set Tiedot = .Range("A1", .Range("A65536").End(xlUp))
End With

With AloitusTaulukko
For Each solu In Tiedot
Nimi = solu
.Range("A1").AutoFilter 1, Nimi
Worksheets.Add().Name = Nimi
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next solu
End With

With AloitusTaulukko
.AutoFilterMode = False
.Activate
End With

On Error GoTo 0
Worksheets("HUUHAA").Delete
Application.DisplayAlerts = True
End Sub

keep excelling :-)
@Kunde
moduuliin...

Sub Väli()
Dim alkupvm As Variant
Dim tokapvm As Variant
Range("A1").Select
alkupvm = Weekday(ActiveCell)
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
tokapvm = Weekday(ActiveCell)
If tokapvm alkupvm Then
ActiveCell.EntireRow.Insert
ActiveCell.Offset(1, 0).Select
End If
alkupvm = tokapvm
Loop
End Sub
soluun mihin haluat nollat piiloon
Range("A1").NumberFormat = "0.00;0.00;"
aivan sivun lopussa
http://www.cpearson.com/excel/duplicat.htm
nyt haluamasi toiminto soluun C1 ja alasvetovalikko soluista A1:A10 ja soluun voi syöttää muitakin arvoja.
Ilman VBA:ta voit tehdä saman tekemällä kelpoisuusehdon listasta ja poistat ruksin virheilmoitus välilehdeltä

Sub Kelpoisuusehto()
With Range("C1").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="=$A$1:$A$10"
.ShowError = False
End With
End Sub
aika simppelisti toi onnistuu excelin omilla erikoistoiminnoilla...

Sub Siirrä()
Dim KopioAlue As Range 'kopioitava alue
Dim SiirtoAlue As Range ' kohdealue
Dim EiTyhjiäAlue As Variant ' eityhjiä rivejä originaali kopioitava alue
On Error Resume Next
Set KopioAlue = Sheets("Originaali").Range("A1:B23") 'muuta kopioitavan taulukonnimi
KopioAlue.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True ' tyhjät piilotetaan
Set EiTyhjiäAlue = KopioAlue.SpecialCells(xlCellTypeVisible) ' kopioidaan vain näkyvät
Set SiirtoAlue = Sheets("Kopio").Range("A1:B23") ' muuta kohdetaulukon nimi
If WorksheetFunction.CountA(SiirtoAlue) = 0 Then 'onko kohdealue tyhjä...
EiTyhjiäAlue.Copy Destination:=SiirtoAlue ' kopioidaan tiedot
Else ' jos ei niin etsitään eka tyhjä oikealle
EiTyhjiäAlue.Copy Destination:=SiirtoAlue.End(xlToRight).Offset(0, 1) ' kopioidaan tiedot
End If
KopioAlue.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False ' tyhjät näkyviin taas
End Sub

keep excelling!
Sub summaa()
Dim summa As Double
For i = 1 To Worksheets.Count
If Worksheets(i).Visible = True Then
summa = summa + Worksheets(i).Range("A1")
End If
Next i
Worksheets(1).Range("F1") = summa
End Sub
jos työkirja sisältää kaavioita. On mennyt käsitteet Sheet ja Worksheet vähän sekaisin...
keep Excelling
=JOS(VERTAA($D$9;"X");$L$19*1000/JOS(VERTAA($A$13;"X")...

ainakin jos D9=x ja A13X niin silloinhan tulee virhe kun jaetaan nollalla!

en kyllä ymmärrä kaavaasi
$L$19*1000/JOS(VERTAA($A$13;"X")
jaetaan joko 1 tai 0 eli ilmeisesti sun jossittelu ei mene oikein...
VBA:n avulla voit tehdä monesti kaavan paljon helpomminkin VBA:n omilla jutuilla
joten tarkistappas nyt ekaksi jossittelusi
mutta kokeiles ensiksi esim.
Range("A1").FormulaLocal= "..."
niin nauhoita makro ja katso mitä se on saanut aikaan...(98% paskaa...)
mutta asiaan...
kirjoita koodiin esim. riippuen kieliversiosta
Range("F16").Formula = "=SUM(A1:A10)" tai
Range("F16").Formula = "=SUMMA(A1:A10)"

voit katsoa myös mitä muita vaihtoehtoja löytyy(auora tai suhteellinen viittaus) kun kirjoittelet VBAeditorissa
Range("F16"). ja katselet mitä vaihtoehtoja löytyy
Keep Excelling
tässä nyt esim. hiiren oikeaan valikkoon

ThisWorkbook moduuliin...

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim Nappi As CommandBarButton
On Error Resume Next
Application.CommandBars("Cell").Controls("Taulukot").Delete
On Error GoTo 0
Set Nappi = Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, Temporary:=True)
With Nappi
.Caption = "Taulukot"
.OnAction = "AvaaTaulukko"
End With
End Sub


ja moduuliin...

Sub AvaaTaulukko()
Application.CommandBars("workbook Tabs").ShowPopup
End Sub
Sub Näkyvät()
For i = 1 To Sheets.Count
If Sheets(i).Visible = True Then
MsgBox Sheets(i).Name
End If
Next
End Sub
63 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt