kunde
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 sitten
Muokkaa profiilia7 aloitusta · 1377 kommenttia
- Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim solu As Range
Dim x
'ohitetaan virhetilanteet
On Error Resume Next
'estetään Excelin reakointi tapahtumiin
Application.EnableEvents = False
'muuta ehto sopivaksi
'täsää käydään solualue läpi solu kerrallaan
For Each solu In Range("F4:F100")
'tarkistetaan onko hinta solussa
If Not IsEmpty(solu) Or IsEmpty(solu.Offset(0, -1)) Then
' piilotetaan rivi, jos hinta solussa
solu.EntireRow.Hidden = True
End If
Next
'määritellään tulostusalue
ActiveSheet.PageSetup.PrintArea = "$A$4:$F$100"
'näytetään tulostuksen esikatselu
ActiveSheet.PrintPreview
x = MsgBox("Tulostetaanko?", vbYesNo, "Tulostus")
If x = 6 Then
'tulostetaan sivu
ActiveWindow.SelectedSheets.PrintOut
Range("A130:A230").Delete
Range("1:100").SpecialCells(xlCellTypeVisible).Copy Range("A130")
End If
'palautetaan piilotetut rivit
Rows("4:100").EntireRow.Hidden = False
'peruutetaan normaalitulostus
Cancel = True
'palautetaan Excel normaalitilaan
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde - Rivi riviltä koodinajo
Valitse koodinsta joku ei kommentti rivi ja painele F8 näppäintä ja koodia suoritetaan rivi kerrallaan. Voit lisätä stopin koodiin klikkaamalla sitä koodialueella vasemmalla olevaa harmaata palkkia hiiren vasemmalla painikkeella. Nyt koodi suoritetaan siihen stopiin asti ja ja jatketaan F8 ivi kerrallaan tai F5 loppuun asti.
Esikatselusta poistut ESC tai klikkaamalla poistunappia. Kysyy sitten haluatkotulostaa jne...
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim solu As Range
'ohitetaan virhetilanteet
On Error Resume Next
'estetään Excelin reakointi tapahtumiin
Application.EnableEvents = False
'muuta ehto sopivaksi
'täsää käydään solualue läpi solu kerrallaan
For Each solu In Range("F4:F100")
'tarkistetaan onko hinta solussa
If Not IsEmpty(solu) Or IsEmpty(solu.Offset(0, -1)) Then
' piilotetaan rivi, jos hinta solussa
solu.EntireRow.Hidden = True
End If
Next
'määritellään tulostusalue
ActiveSheet.PageSetup.PrintArea = "$A$4:$F$100"
'näytetään tulostuksen esikatselu
ActiveSheet.PrintPreview
x = MsgBox("Tulostetaanko?", vbYesNo, "Tulostus")
If x = 6 Then
'tulostetaan sivu
ActiveWindow.SelectedSheets.PrintOut
End If
'palautetaan piilotetut rivit
Rows("4:100").EntireRow.Hidden = False
'peruutetaan normaalitulostus
Cancel = True
'palautetaan Excel normaalitilaan
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde - Resetointi makro on siltä varalle, jos koodia askel askeleelta suoritat ja koko makroa ei ajeta loppuun syystä tai toisesta eli toi rivi jää suorimattamatta, ei Excelsitten reagoitapahtumiin. Siis ihan helpottamaan elämää toi koodi... ;-)
tossa nyt pyytämäsi päivitykset
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim solu As Range
'ohitetaan virhetilanteet
On Error Resume Next
'estetään Excelin reakointi tapahtumiin
Application.EnableEvents = False
'muuta ehto sopivaksi
'täsää käydään solualue läpi solu kerrallaan
For Each solu In Range("F4:F100")
'tarkistetaan onko hinta solussa
If Not IsEmpty(solu) Or IsEmpty(solu.Offset(0, -1)) Then
' piilotetaan rivi, jos hinta solussa
solu.EntireRow.Hidden = True
End If
Next
'määritellään tulostusalue
ActiveSheet.PageSetup.PrintArea = "$A$4:$F$100"
'tulostetaan sivu
ActiveWindow.SelectedSheets.PrintOut
'palautetaan piilotetut rivit
Rows("4:100").EntireRow.Hidden = False
'peruutetaan normaalitulostus
Cancel = True
'palautetaan Excel normaalitilaan
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde - mun koodissa piilota rivit 8- haluamasi määrä alaspäin
sitten liität koodin ko.taulukon moduuliin ja alat syöttelemään tietoja niin poistaa piilotuksen aktiivinen solu 2
eli kun lisäät tietoa (muutat solunarvoa) 6 rivillä niin 8 rivi tulee näkyviin ja 7 rivillä sitten 9 rivi tulee näkyviin jne... - jos antamasi kaava toimii niin kuten sanoin postauksessani löydät oikean sarakkeen ko päivänä
Application.WorksheetFunction.Match(cdbl(Date), Range("8:8"))...
lisättynä toimivaan koodiisi
Private Sub ToggleButton1_Click()
On Error Resume Next
If ToggleButton1.Value = True Then
ActiveSheet.Range("$A$8:$CDZ$95").AutoFilter Field:=Application.WorksheetFunction.Match(CDbl(Date), Range("1:1")), Criteria1:=RGB(255, 0 _
, 0), Operator:=xlFilterCellColor
Else
ActiveSheet.Shapes.Range(Array("ToggleButton1")).Select
ActiveSheet.Range("$A$8:$CDZ$95").AutoFilter Field:=Application.WorksheetFunction.Match(CDbl(Date), Range("1:1"))
End If
End Sub
Keep EXCEling
@Kunde - Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim solu As Range
'ohitetaan virhetilanteet
On Error Resume Next
'estetään Excelin reakointi tapahtumiin
Application.EnableEvents = False
'muuta ehto sopivaksi
'täsää käydään solualue läpi solu kerrallaan
For Each solu In Range("F4:F100")
'tarkistetaan onko hinta solussa
If Not IsEmpty(solu) Or IsEmpty(solu.Offset(0, -1)) Then
' piilotetaan rivi, jos hinta solussa
solu.EntireRow.Hidden = True
End If
Next
'tulostetaan sivu
'ActiveWindow.SelectedSheets.PrintOut
'palautetaan piilotetut rivit
Rows("4:100").EntireRow.Hidden = False
'peruutetaan normaalitulostus
Cancel = True
'palautetaan Excel normaalitilaan
Application.EnableEvents = True
End Sub
Keep EXCEling
@Kunde - automaatisesti löydät sarakkeen VBA:ssa
Application.WorksheetFunction.Match(cdbl(Date), Range("8:8"))
Keep EXCEling
@Kunde - koodi ThisWorkbook moduuliin...
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim solu As Range
'ohitetaan virhetilanteet
On Error Resume Next
'estetään Excelin reakointi tapahtumiin
Application.EnableEvents = False
'muuta ehto sopivaksi
'täsää käydään solualue läpi solu kerrallaan
For Each solu In Range("F4:F100")
'tarkistetaan onko hinta solussa
If Not IsEmpty(solu) Then
' piilotetaan rivi, jos hinta solussa
solu.EntireRow.Hidden = True
End If
Next
'tulostetaan sivu
ActiveWindow.SelectedSheets.PrintOut
'palautetaan piilotetut rivit
Rows("4:100").EntireRow.Hidden = False
'peruutetaan normaalitulostus
Cancel = True
'palautetaan Excel normaalitilaan
Application.EnableEvents = True
End Sub
Keep EXCEling
@Kunde - ThsiWorkbook moduuliin...
Private Sub Workbook_BeforePrint(Cancel As Boolean)
On Error Resume Next
Application.EnableEvents = False
'muuta ehto sopivaksi
If ActiveSheet.Range("H1") = 1 Then
'muuta rivit sopivaksi
Rows("6:9").EntireRow.Hidden = True
ActiveWindow.SelectedSheets.PrintOut
Rows("6:9").EntireRow.Hidden = False
Cancel = True
Application.EnableEvents = True
End If
End Sub - ko. taulukon moduuliin....
muuta rivit sopivaksi
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Rows("6:20")) Is Nothing Then
Application.EnableEvents = False
Target.Offset(2, 0).EntireRow.Hidden = False
Application.EnableEvents = True
End If
End Sub
Keep EXCELing
@Kunde - Sub Suojaa()
Dim i As Long
For i = 1 To Sheets.Count
Sheets(i).Protect
Next
End Sub
Sub PoistaSuojaus()
Dim i As Long
For i = 1 To Sheets.Count
Sheets(i).Unprotect
Next
End Sub
Keep EXCELing
@Kunde - Et ole ymmärtänyt ohjeitani oikein ja olet sekoittanut nyt vanhaa ja uutta koodia keskenään...
Väännetään vielä rautalangasta, eli hakuarvo solussa C2 ja vaihteluväli solussa C1. Hakualue on A24:D600 ja haen sarakkeesta D eli arvolla 4, tällöin
Ensimmäinen koodini oli oma funktio ja jälkimmäinen podtaamani koodi ei ole oma funktio, vaan perustuu solujen muutokseen taulukossa. Eka näkyi, mutta jälkimmäisen ei näy funktiolistassa
2 eri versiota
versio1.
MODUULIIN....
Sub OmaPHaku(Haku As Double, Hakualue As Range, Vaihteluväli As Double, Sarake As Long)
i = 0
ReDim Tulos(0)
'tulos sarakkeeseen L
Range("B:B") = ""
For Each Solu In Hakualue
If Solu >= Haku - (Vaihteluväli / 100) * Haku And Solu <= Haku (Vaihteluväli / 100) * Haku Then
Tulos(i) = Solu.Offset(0, Sarake - 1)
i = i 1
ReDim Preserve Tulos(i)
End If
Next
Range("B1").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)
End Sub
SEN TAULUKON MODUULIIN MISSÄ TIEDOT ON ESIM TAUL1 MODUULIIN....
Taul1 solut ja niiden merkitys on alla ja jos haluat muuttaa niin muutat koodissa
esim. soluissa tekstit
'C1 = hakuarvo =27,5
'C2 = vaihteluväli=10
hakualue har codattu koodiin samoin kuin sarake
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Range("C1:C2"), Target) Is Nothing Then
OmaPHaku Range("C1"), Range("A24:D600"), Range("C2"), 4
End If
Application.EnableEvents = True
End Sub
versio 2
mitä tarjosin aluksi, siinä voi hakualueen ja sarakkeen kanssa syöttää soluihin
MODUULIIN...
Sub OmaPHaku(Haku As Double, Hakualue As String, Vaihteluväli As Double, Sarake As Long)
i = 0
ReDim Tulos(0)
'tulos sarakkeeseen L
Range("B:B") = ""
For Each Solu In Range(Hakualue)
If Solu >= Haku - (Vaihteluväli / 100) * Haku And Solu <= Haku (Vaihteluväli / 100) * Haku Then
Tulos(i) = Solu.Offset(0, Sarake - 1)
i = i 1
ReDim Preserve Tulos(i)
End If
Next
Range("B1").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)
End Sub
SEN TAULUKON MODUULIIN MISSÄ TIEDOT ON ESIM TAUL1 MODUULIIN....
Taul1 solut ja niiden merkitys on alla ja jos haluat muuttaa niin muutat koodissa
esim. soluissa tekstit
'C1 = hakuarvo =27,5
'C2 = vaihteluväli=10
'C3= hakualue=A24:D600
'C4= sarake=4
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Range("C1:C4"), Target) Is Nothing Then
OmaPHaku Range("C1"), Range("C3"), Range("C2"), Range("C4")
End If
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde - jos haluat esim. ruksin tms se onnistuu helposti.
Tsekkaa lisää merkin code ja fontti ja muuta koodiin
eli nyt Wingdings fontti ja ruksi merkki ja alhaalta luet Char code(vaihda mistä Symbol dec)
eli lissä merkki ja sieltä Wingdings ja sit ohjeen mukaan...
koodissa code(80) vastaa P-kirjainta normaalitekstissä, mutta fontilla Wingdings2 se on se harakanvarvas
eli omassa kaavassasi pitää vaihtaa X kirjain P kirjaimeksi...
Keep EXCELing
@Kunde - niin ja oisessa koodin pätkässä siis tulos sarakkeeseen L
muuta tarvittaessa
'tulos sarakkeeseen L
Range("L:L") = ""
...
...
...
Range("L1").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)
Keep EXCELing
@Kunde - lisäsit koodin uuteen moduuliin...
ko taulukon moduuliin tarkoittaa sitä, että koodi lisätään sen taulukon moduuliin missä sen halutaan toimivan. Toki koodata voisin This Workbookiin kanssa, mutta sitten pitää tsekata , että koodi toimii vaan esim. Taul1:ssä eikä muissa. Mutta kätevää toisaalta, jos tarttee useammassa taulukossa samaa koodia....
eli jos jutut on Taul1:ssä niin kopioi alla oleva koodi siis sinne
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("H1:K1"), Target) Is Nothing Then
OmaPHaku Range("H1"), Range("I1"), Range("J1"), Range("K1")
End If
End Sub
Taul1 solut ja niiden merkitys on alla ja jos haluat muuttaa niin muutat koodissa
esim. soluissa tekstit
'H1 = hakuarvo =27,5
'I1 = hakualue =B1:B100
'J1 =vaihteluväli =5
'K1 = palautettava sarake =2 eli hakualueesta seuraava sarake oikealle tai voi hakea vasemmallekin 0 on eka sarake vasemmalle jne. - Solverilla onnistuu
laita A sarakkeeseen maksetut summat esim A1:A9
vastaaviin C sarakkeen soluihin kaava =A1*B1 ja kopioi kaavaa vetämällä alas
esim soluun C10 laita kaava = SUMMA(C1:C9)
avaa solveri
lomakkeella syötä seuraavat arvot
Set objective = C10
value of kohtaan täppä ja sille maksettu summa
By changing variable cells kohtaan = B1:B9
vakioruutuun klikkaa lisää ja avautuvassa lomakkeessa cell reference= B1:B9 ja viereisestä valikosta valitse bin
Make unconstrained variables non-negative poista siitä täppä
klikkaa solve
avautuvasta valikosta keep solver solution ja OK
keep EXCELing
@Kunde - helpoin ja nopein tapa tehdä oma funktio...
moduuliin...
soluun kaava esim. =OmaPHaku(G1;A1:A100;5;2), missä
G1=hakuarvo
A1:A100= hakualue arvolle
5= vaihteluväli arvolle /-
jos eri positiivisilla ja negatiivisella , niin helppo fiksata kaavaan tarvittaessa
2=sarake
hakuarvo sarake on 1, joten arvo 2 palauttaa hakusarakkeen oikeanpuolella olevan sarakkeen arvot. Vastaavasti arvolla 0 palauttaisi vasemmanpuoleisen sarakkeen arvot
Function OmaPHaku(Haku As Double, Hakualue As Range, Vaihteluväli As Double, Sarake As Long)
Dim Solu As Range
Dim Tulos As String
xResult = ""
For Each Solu In Hakualue
If Solu >= Haku - (Vaihteluväli / 100) * Haku And Solu <= Haku (Vaihteluväli / 100) * Haku Then
Tulos = Tulos & Solu.Offset(0, Sarake - 1) & ", "
End If
Next
OmaPHaku = Left(Tulos, Len(Tulos) - 2)
End Function
Keep EXCELing
@Kunde - Mitä olet tutkimassa
Mitä ovat noi x ja y ja niiden suhde
virhemarginaali
ei voi ihan lonkalta antaa vastausta ei lineaariseen
ensiksi sun pitää selvittää miten arvot käyttäytyvät eli selvittää funktion muoto ja kaava sille
sen jälkeen tehdä hieman esivalmisteluja ja sitten EXCElin raikaisija avuksi ... - ajattelin, että pitäisi kyllä olla helpompikin keino säädellä kopioitavan alueen sarakkeiden paikkaa ja määrää...
Sub Siirrä()
Dim vika As Long
Dim ar As Variant
vika = Worksheets("Sheet2").Range("B65536").End(xlUp).Row 1
With Sheet1.Range("B4:O100")
'arrayssa voit määritellä kopioitavien sarakkeiden järjestyksen ja samalla määrän ;-) ...
ar = Application.Index(.Value, Evaluate("row(1:100" & ")"), Array(1, 2, 3, 8, 6, 7, 9, 10, 11, 12, 13, 14))
Worksheets("Sheet2").Range("B" & vika).Resize(UBound(ar), 12) = ar
End With
End Sub
Keep EXCELing
@Kunde - ei ihan vastaa toi solualue taulukko2;ssa, mutta ei väliä. Muuta koodissa nimet ja alueet sopiviksi.
Sub Siirrä()
Dim vika As Long
vika = Worksheets("Sheet2").Range("B65536").End(xlUp).Row 1
With Worksheets("Sheet1")
Union(.Range("B4:D100"), .Range("J4:J100")).Copy Worksheets("Sheet2").Range("B" & vika)
Union(.Range("G4:I100"), .Range("K4:O100")).Copy Worksheets("Sheet2").Range("F" & vika)
End With
End Sub
keep EXCELing
@Kunde