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 CommandButton1_Click()
Dim vika As Long
vika = Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Offset(1, 0).Column 1
Union(Range("A1:A4"), Range("A11:A20")).Copy Worksheets("Sheet2").Cells(1, vika)
End Sub
Keep EXCELing
@Kunde - yksinkertaisesti ilman luuppeja...
vaihda taulukon nimi, johon siirretään sopivaksi samoin kuin sarakkeet
Private Sub CommandButton1_Click()
Dim vika As Long
vika = Worksheets("Sheet2").Range("A65536").End(xlUp).Row
Union(Range("A1:A4"), Range("A11:A20")).Copy Worksheets("Sheet2").Range("A" & vika 1)
End Sub
Keep EXCELing
@Kunde - win 10 päivittelee...
- Kokeile+vaihtaa+muuttujatyyppi+Dim+s+As+Variant
- ISOWEEKNUM palauttaa päiväyksestä viikkonumeron eikä päinvastoin kuten kysyjä haluaa...
- Kannattaa tutustua Tushar Mehtan sivuihin. Siellä huippuosaamista.
tossa esim. sulle sopiva kikkailu...
http://www.tushar-mehta.com/publish_train/xl_vba_cases/0411 logarithm scale on x axis.shtml
Keep EXCELing
@Kunde - perusidea ....
Sub Testi()
On error GoTo Virhe
'koodia...
Exit Sub
Virhe:
'korjaustoimenpiteitä virheelle
Resume Next
End Sub - ISO-standardi määrittelee vuoden ensimmäisen viikon näin:
- viikko alkaa maanantailla, joten maanantai on ensimmäinen päivä jokaisella viikolla
- vuoden ensimmäisen viikon pitää sisältää vähintään 4 päivää ko. vuodella
tästä seuraa, että
1. 1.1. on viikolla 1, jos se on maanantai, tiistai, keskiviikko tai torstai
2. 4.1 on aina viikolla 1 minä tahansa vuonna
3. vuoden ensimmäinen torstai on aina viikolla 1
Laskutoimitukset:
Määritellään viimeinen sunnuntai edelliseltä vuodelta
Lisätään viikkojen määrä-1 kerrottuna 7
Lisätään viikonpäivännumero päivälle jota haetaan
vuosi: 4 numeroa
viikonnumero: 1...53
päivännumero: maanantai=1, tiistai=2 jne...
Dateserial(vuosi,1,4) (väittämä 2) on aina viikolla 1
ISO-standardissa maanantai on aina viikon ensimmäinen päivä
vähennetään päiväyksestä 4.1 sen päivänumero ja tuloksena saadaan edeltävä sunnuntai ennen päiväystä 4.1
DateSerial(vuosi,1,4)- Weekday(DateSerial(vuosi, 1, 4), 2)
2 kaavassa tarkoittaa, että viikko alkaa maanataista
Lisätään viikkojen määrä-1 kerrottuna 7
7*(viikko-1) Dateserial(vuosi,1,4)- Weekday(DateSerial(vuosir, 1, 4), 2)
Lisätään viikonpäivännumero päivälle jota haetaan
7*(viikko-1) Dateserial(vuosi,1,4)- Weekday(DateSerial(vuosir, 1, 4), 2) päivänumero
eli maanantai viikolle 10
7*(10-1) Dateserial(2017,1,4)- Weekday(DateSerial(2017, 1, 4), 2) 1
moduuliin...
Function ISOPäiväys(Vuosi As Integer, Viikko As Integer, Päivä As Integer) As Long
ISOPäiväys = 7 * (Viikko - 1) DateSerial(Vuosi, 1, 4) - Weekday(DateSerial(Vuosi, 1, 4), 2) Päivä
End Functio
kaavat C3= viikkonumero , mille haetaan päiväys
C8=isopäiväys(2017;C3;1)
C9=C8 1 jne...
Keep EXCELing
@Kunde - Lisää ActiveX komponenteista yhdistelmäruutu ja ominaisuuksissa(tuplaklikkaa yhdistelmäruutua suunnittelutilassa) laitat
BoundColumn = 2
ListFillRange alue missä on nimet ja vastaavat koodit esim A1:B100
LinkedCell= solu mihin haluat numeron tulevan
Keep EXCELing
@Kunde - foorumi on poissa käytöstä tällä hetkellä....
palaa takaisin jonkin ajan kuluttua- toivon mukaan...
Kunde - jos valitaan sarake reilut miljoona luuppia tekee, vaikka tarvitsisi esim. 30 riviä käydä läpi ;-)
- moduuliin...
Sub Siirrä()
Dim Alue As Range
For i = 1 To 6
Set Alue = Etsi(i)
Alue.Offset(0, i 1) = Alue.Offset(0, 1)
Next
Columns("B:B").Delete
End Sub
Function Etsi(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
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
Keep EXCELing
@Kunde - Oikeassa olet noiden pointtien suhteen, mutta tossa nyt fiksattu versio... ;-)
Function SummaX2(a As Variant) As Double
SummaX2 = StrReverse(Val(StrReverse(Replace(a, " ", ""))))
End Function
Keep EXCELing
@Kunde - ="-"& TRIM(SUBSTITUTE(RIGHT(A1;LEN(A1)-FIND("|";SUBSTITUTE(A1;" ";"|";LEN(A1)-LEN(SUBSTITUTE(A1;" ";""))-1)));"-";""))
="-"& POISTA.VÄLIT(VAIHDA(OIKEA(A1;PITUUS(A1)-ETSI("|";VAIHDA(A1;" ";"|";PITUUS(A1)-PITUUS(VAIHDA(A1;" ";""))-1)));"-";""))
Keep EXCELing
@Kunde - VBA puolella INSERT/MODUL ja kopioit koodin oikealle valkoiselle alueelle.
Soluun mihin haluat kaava
=SummaX(A1), nyt siis solusta A1 haetaan summa
moduuliin..
Function SummaX(a As Variant) As Double
Dim b as VAriant
b = Split(Replace(StrReverse(Trim(a)), ".", ","), " ")
Summax = CDbl(StrReverse(b(0)) & StrReverse(b(1)))
End Function
Keep EXCELing
@Kunde - Miksi pitää siirtää Wordiin?
Excelissä voit tehdä kaikki samat jutut kuin Wordissä ja paljon helpommalla. - Tekee muotoilut tulostukseen ja poistaa ne tulostuksen jälkeen
muuta alku ja loppuarvot sopiviksi samoin kuin viivalaji
tavalliseen moduuliin...
Sub Viivat()
Dim Alku As Long
Dim Loppu As Long
Alku = 5
Loppu = 20
For rivi = Alku To Loppu Step 5
With Range("A" & rivi & ":M" & rivi).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDash
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End With
Next
End Sub
Sub ViivatPois()
Dim Alku As Long
Dim Loppu As Long
Alku = 5
Loppu = 20
Range("A" & Alku & ":M" & Loppu).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select
End Sub
ja ThisWorkbook (Tämä työkirja) moduuliin...
Private Sub Workbook_BeforePrint(Cancel As Boolean)
On Error Resume Next
Application.EnableEvents = False
Viivat
ActiveWindow.SelectedSheets.PrintOut
ViivatPois
Application.EnableEvents = True
Cancel = True
End Sub
Keep EXCELing
@Kunde - No ei tossa kauan aikaa mennyt
Mutta ei nyt mitään merkittävää etua, koska toi nimenantajan vinkki toimii hyvin, koska sulla oli se solu, josta kopioit sen muihin. Jäi huomioimatta mulla ;-)
Muuten koodini olisi ihan ehdoton.
tossa testataan muutettava kelpoisuusehto
If Solu.Validation.Formula1 = "=$A$50:$A$100"
ja tossa muutetaan uusi ehto
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$A$50:$A$102"
ja lopuissa sitten voi tehdä ilmoituksiin muutoksia
Vielä helpommalla pääset kun teet jatkossa listasi dynaamiseksi siirtymä(offset) funktiolla ja silloin ei tarvitse muuta, kuin lisäillä tai poistaa nimiä luettelosta ja toimii automaattisesti...
Keep EXCELing
@Kunde - tavalliseen moduuliin...
Sub testi()
Dim Solu As Range
On Error Resume Next
For Each Solu In Cells.SpecialCells(xlCellTypeAllValidation)
If Solu.Validation.Formula1 = "=$A$50:$A$100" Then
With Solu.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$A$50:$A$102"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
Next
On Error GoTo 0
End Sub
Keep EXCELing
@Kunde - ="D= " & VAIHDA(F3;",";".")& " , h="& VAIHDA(F4;",";".")
Keep EXCELing
@Kunde