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
oiskos tosta apua?
testasin tota ja peruutusten määrää oli helppo muutella

http://support.microsoft.com/kb/211922
vikana-eli Sort Key1:=ActiveCell jolloin aina lajitellaan aktiivisen solun mukaan
alla hieman siistittynä(ilman virhetarkasteluja ja N-sarake testiä) sama koodin pätkä

Sub testi()
Const NumColums As Integer = 14 '(Makron pitää laska tuosta valinnasta esim. 13 solua oikealle )

With ActiveCell.Resize(1, NumColums)
.Sort Key1:=ActiveCell, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal
End With
ActiveCell.Select
End Sub
Määritä nimi Tu ja laita sille arvoksi =-26
siinäpä se...
tee nappi ja liitä allaoleva koodi siihen. Värjää aktiivisesta solusta(oikealleja alas) korkeus*leveys kokoisen alueen keltaiseksi. Muuta vakioita ja värikoodia(kelt.=6)

moduuliin...

Const Korkeus As Integer = 6
Const Leveys As Integer = 10
Sub Maalaa()
ActiveCell.Resize(Korkeus, Leveys).Interior.ColorIndex = 6
End Sub
makron pitää toimia alhaalta ylöspäin... ;-)
käytä solun omaa muotoilua ja lisää sinne puuttuvat värit ja niille tarvittavat rajaehdot.
Tietenkin VBA:lla sitten saat vaihtoehtoja riittävästi
kopsaamalla sen osan vaikkapa uudelle layerille eri paikkaan ja koodaamalla hiukan niin pitäs ton onnistua ihan hyvin...
If unsaved workbooks are open when you use this method, Microsoft Excel displays a dialog box asking whether you want to save the changes. You can prevent this by saving all workbooks before using the Quit method or by setting the DisplayAlerts property to False. When this property is False, Microsoft Excel doesn’t display the dialog box when you quit with unsaved workbooks; it quits without saving them.

If you set the Saved property for a workbook to True without saving the workbook to the disk, Microsoft Excel will quit without asking you to save the workbook.

joten kyllä allaoleva pitäisi toimia (toimii ainakin mulla)

Sub Sulje()
Application.DisplayAlerts = False
Application.Quit
End Sub

suljetaan kaikki muut työkirjat yksitellen tallentamatta niitä (tai jos tarttee tallentaa niin muuta Työkirja.Close False---> Työkirja.Close True)-paitsi yksi (1 pitää olla aina auki..) eli jätetään yksi sulkematta ja sitten suljetaan se lopuksi.
Nyt ei ainakaan pitäisi herjoja tulla...


Sub Sulje2()
Dim Työkirja As Workbook
Application.DisplayAlerts = False

For Each Työkirja In Application.Workbooks
If Työkirja.Name "suljevikana.xls" Then ' muuta tähän aukijäävän työkirjan nimi
Työkirja.Close False
End If
Next

Application.Quit
End Sub

ohjeen mukaisesti...
kerrotaan Excelille , että ollaankin tallennettu työkirjat... ;-)

Sub Sulje3()
Dim Työkirja As Workbook
For Each Työkirja In Application.Workbooks
   Työkirja.Saved=True
Next

Application.Quit
End Sub

ei nyt muuta tuu mieleen tällä erää... jospa noilla probleema korjautuisi

Keep Excelliong
@Kunde
tee haluamasi tunnisteet ja tallenna haluamallasi nimellä XLSTART kansioon. Nyt kun avaat excelin, niin se avaa tämän kansiossa olevan tiedoston automaattisesti...
kansio on oletusasennuksella tuolla C:\Program Files\Microsoft Office\Office10\XLStart
moduuliin...
Option Explicit

Sub AutoFit()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Next
End Sub
onhan sulla nyt varmasti haettavat viikot sarakkeessa D?
kun en tiedä tarkemmin taulukon rakennetta niin tossa tommonen yleinen. Laittaa nyt lisättävän rivin A soluun kommentin, jossa muutoksen tekijän nimi ja aika. Helppo muutella toiveittesi mukaan

keräilytaulukon moduuliin...

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Target.Cells(1, 1).ClearComments
Target.Cells(1, 1).AddComment.Text Text:=Format(Date, "mm-dd-yyyy") & Chr(10) & "Muokannut " & Environ("UserName")
End If
End Sub
nyt ei väliä missä kohtaan sarakkeessa viikot on esim. tyyliin 31,32,31,33,32,31,31,31,32,32,32,34,35 jne.


Dim EiTupla As New Collection
Dim Taulukko As Worksheet
Dim i As Integer
Dim Löydetty As Range
Dim Haku As Variant

Sub LisääTaulukko()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Worksheets("Sheet1").Activate
Vika = Range("D65536").End(xlUp).Row
For Each solu In Range("D1:D" & Vika)
If Not IsEmpty(solu) Then
EiTupla.Add solu.Value, CStr(solu.Value)
End If
Next solu
For i = 1 To EiTupla.Count
For Each Taulukko In Worksheets
If Taulukko.Name = EiTupla(i) Then
Taulukko.Delete
End If
Next Taulukko
Sheets.Add.Name = EiTupla(i)
ActiveSheet.Move After:=Sheets(Sheets.Count)
Haku = EiTupla(i)
Set Löydetty = EtsiJaSiirrä(Haku, Range("Sheet1!D1:D" & Vika)).EntireRow
Union(Löydetty, Löydetty).Copy Range(Haku & "!A65536").End(xlUp).Offset(1, 0).EntireRow

Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With HakuAlue
Set solu = .Find( _
What:=Hakuehto, _
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
taulukoiden rajana koneen muisti...
tolla nyt pääset alkuun ja sitä on helppo muokkailla itselle sopivaksi

Option Explicit
Sub LisääTaulukko()
Dim Taulukko As Worksheet
Dim Vika As String
Dim solu As Range
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Sheet1").Activate
Vika = Range("D65536").End(xlUp).Row
For Each solu In Range("D1:D" & Vika)
For Each Taulukko In Worksheets
If Taulukko.Name = solu Then
Taulukko.Delete
End If
Next Taulukko
solu.EntireRow.Copy
Sheets.Add.Name = solu
ActiveSheet.Paste
Range("A1").Select
ActiveSheet.Move After:=Sheets(Sheets.Count)
Next solu
Application.CutCopyMode = False
Application.DisplayAlerts = True
End Sub

Keep Exceling
@Kunde
kuten ekassa postauksessani sanoin, vaihda vakioita
vauhda koodissa
LookAt:=xlWhole--->LookAt:=xlPart
Set Löydetty = EtsiJaSiirrä(R1C1).EntireRow
ei tunnista tota R1C1 soluksi A1, all hiukan muunneltuna ja korjattuna makrot


Function EtsiJaSiirrä(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet3").Activate
With Cells
Set solu = .Find( _
What:=Hakuehto, _
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
Worksheets("Sheet1").Activate
Range("A1").Select
End Function

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

On Error GoTo virhe
Haku = Worksheets("Sheet1").Range("A1")
Set Löydetty = EtsiJaSiirrä(Haku).EntireRow
Union(Löydetty, Löydetty).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub
eräs JMS ei osannut kuin jossitella vähän... ja tällä tavalla hän oppi jossittelemaan lisää. alla linkkejä asian tiimoilta. vikassa taitaa olla se ratkaisu ;-)

http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000013429271#22000000013429271

http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000014687994#22000000014687994

http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000018460202#22000000018460202
moduuliin...
etsii nyt sheet1:stä arvoa 11 ja siirtää löydetyt rivit sheet2:lle ekalle tyhjälle riville A- sarakkeessa
muuttele vakioita tarpeesi mukaan...
LookIn:=xlValues-xlFormulas
LookAt:=xlWhole-xlPart
MatchCase:=False-True

Function EtsiJaSiirrä(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With Cells
Set solu = .Find( _
What:=Hakuehto, _
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

Sub Testi()
Dim Löydetty As Range
On Error GoTo virhe
Set Löydetty = EtsiJaSiirrä(11).EntireRow
Union(Löydetty, Löydetty).Copy Range("Sheet2!A65536").End(xlUp).Offset(1, 0).EntireRow
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub
moduuliin...
ja soluun mihin haluat tuloksen niin kaavaksi esim.
=SummaVärillä(A1:A1000)

HUOM!
funktio ei päivity, kun muutat solun väriä joten se pitää resetoida esim. painamalla näppäinyhdistelmää CTRL+ALT+F9
tietenkin tohon olis pitänyt lisätä eriväreille mahdollisuus, mutta olkoon nyt noin

Function SummaVärillä(Alue As Range) As Double
For Each solu In Alue
If solu.Interior.ColorIndex = xlNone Then
SummaVärillä = SummaVärillä + solu
End If
Next solu
End Function
moduuliin...

Sub Kopioi()
Dim Lähdealue As Range
Dim vika As Integer

vika = Range("G65536").End(xlUp).Row
Set Lähdealue = Range("G1:G" & vika)
Range("D2").Select
For i = 1 To Lähdealue.Count
ActiveCell = Lähdealue(i)
ActiveCell.Offset(2, 0).Select
Next
End Sub

Keep Exceling
@Kunde
58 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt