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 LeikkaaJaSirrä()
'leikkaa rivit 1-10000 uuteen taulukkoon Data1,Data2 jne
'tiedot oletuksena Taulukossa Sheet1
Sheets("Sheet1").Activate
For i = 1 To 10
Rows("1:10000").Cut
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Data" & i
ActiveSheet.Paste
Sheets("Sheet1").Activate
Rows("1:10000").Delete Shift:=xlUp
Next
End Sub
vanhoja yhdistäen ;-)

moduuliin...

Sub lajittele()
Dim solu As Range
Dim vika As Long
Dim i As Long
Dim EiTupla As New Collection
Dim Löydetty As Range

On Error GoTo virhe
Vika = Range("E65536").End(xlUp).Row
For Each solu In Range("E1:E" & Vika)
If Not IsEmpty(solu) Then
EiTupla.Add solu.Value, CStr(solu.Value)
End If
Next solu
Range("F:G") = ""
Range("F1").Select
For i = 1 To EiTupla.Count
ActiveCell = EiTupla(i)
ActiveCell.Offset(1, 0).Select
Next
Columns("F:F").Sort Key1:=Range("F1"), Order1:=xlAscending
Vika = Range("F65536").End(xlUp).Row
For Each solu In Range("F1:F" & Vika)
Set Löydetty = EtsiJaSiirrä(solu)
solu.Offset(0, 1) = Löydetty.Cells.Count
Next
Exit Sub
virhe:
Resume Next
End Sub


Function EtsiJaSiirrä(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With Range("E:E")
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

Keep Excelling
@Kunde
että homma toimii...
Ko funktio on todella monipuolinen, mutta sehän perustuukin Range- objektiin, mikä on mitä monipuolisin objekti Excelin kirjastossa. Soveltamalla saa aikaiseksi uskomattomia juttuja parin rivin koodilla ...

Tattista vaan
Keep Excelling
@Kunde
en ollut varma halusitko siirtää vain A-sarakkeen vaiko sarakkeiden A-N tiedot, joten fiksasin molemmat...


Option Explicit
Function EtsiJaSiirrä(Hakuehto As Variant) As Range
'etsii Sheet1 sarakkeesta A ja siirtää Sheet2 sarakkeeseen O
'oletuksena, että siirrettävät tiedot sarakkeissa A-N
Dim solu As Range
Dim solulaajennus As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
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 EtsiJaSiirrä = solu
EkaOsoite = solu.Address
Set solulaajennus = solu.Resize(1, 14)
Do
Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solulaajennus)
Set solu = .FindNext(solu)
Set solulaajennus = solu.Resize(1, 14)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
End Function

Sub Testi()
Dim Löydetty As Range
Dim alue As Areas
Dim Alueetlkm As Integer
Dim i As Integer
Dim Ylärivi As Long
Dim Vasensarake As Long
Dim YläVasen As Range
Dim KopioitavatAlueet() As Range

On Error GoTo virhe
Range("Sheet2!O:AB") = ""
Set Löydetty = EtsiJaSiirrä(11)
Alueetlkm = Löydetty.Areas.Count
ReDim KopioitavatAlueet(1 To Alueetlkm)
For i = 1 To Alueetlkm
Löydetty.Areas(i).Copy Range("Sheet2!O65536").End(xlUp).Offset(1, 0)
Next
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub

Function EtsiJaSiirrä2(Hakuehto As Variant) As Range
'etsii Sheet1 sarakkeesta A ja siirtää Sheet2 sarakkeeseen O
'oletuksena, että haettavat tiedot vain sarakkeessa A
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
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 EtsiJaSiirrä2 = solu
EkaOsoite = solu.Address
Do
Set EtsiJaSiirrä2 = Union(EtsiJaSiirrä2, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
End Function

Sub Testi2()
Dim Löydetty As Range
On Error GoTo virhe
Set Löydetty = EtsiJaSiirrä2(11)
Range("Sheet2!O:O") = ""
Löydetty.Copy Range("Sheet2!O65536").End(xlUp).Offset(1, 0)
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub
Sub Luokittele()
Dim vika As Long
Dim solu As Range
vika = Range("B65536").End(xlUp).Row
For Each solu In Range("B1:B" & vika)
Select Case solu
Case Is > 2000
solu.Offset(0, 1) = "yli 2000"
Case Is >= 1900
solu.Offset(0, 1) = "1900-2000"
Case Is >= 1800
solu.Offset(0, 1) = "1800-1900"
'jne
Case Else
solu.Offset(0, 1) = "ei tietoa"
End Select
Next
End Sub
ilman koodia ei onnistu...

pikku kikkailulla

taulukon moduuliin...
nyt solussa H1 kelpoisuustarkistus ja kelpoisuusluettelo on soluissa E1:EXXX
voi vapaasti poistella arvoja listasta tai lisätä uusia listaan ja jättää jopa tyhjiä soluja väliin. Kun valitaan H1, niin poistaaaluksi tyhjät luettelosta ja päivittää kelpoisuusehdon H1 soluun.
Helppo lisätä uusia kelpoisuusehto soluja ja muokata koodia lueetelon suhteen

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim vika As Long
If Not Intersect(Target, Range("H1")) Is Nothing Then
vika = Range("E65536").End(xlUp).Row
Range("E1" & vika).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
vika = Range("E65536").End(xlUp).Row
With Range("H1").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="=$E$1:$E$" & vika
End With
End If
End Sub

Keep Excelling
@Kunde
kysyttiin samaa asiaa...
http://keskustelu.suomi24.fi/node/9109932
luulin, että osaat soveltaa...
koodi pitää olla samalla rivillä, nyt heittää se n tässä 2 riville...

Sub KopioiToisestaToiseen()
Workbooks("Koe1").Worksheets("Sheet1").Range("A1").EntireRow.Copy Workbooks("Koe2").Worksheets("Sheet1").Range("A1")
End Sub
Sub KopioiToisestaToiseen()
Workbooks("Koe1").Worksheets("Sheet1").Range("A1").Copy Workbooks("Koe2").Worksheets("Sheet1").Range("A1")
End Sub

Keep Excelling ;-)
@Kunde
turhat luupit ja jossittelut pois...
Sub RunRun
Dim Taulukko as WorkSheet
For Each Taulukko In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
Taulukko.Activate
Laske
Next
End Sub
moduuliin...
nyt Sheet1 taulukko oletuksena

Sub Auto_Open()
Worksheets("Sheet1").Activate
ActiveWindow.Zoom = 130
End Sub
taulukon moduuliin...
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A1")) Is Nothing Then
ActiveSheet.Name = Range("A1")
End If
End Sub
viittaisi siihen, että taulukko ei ole aktiivinen
tai taulukko on suojattu
tai solu lukittu.
Voisiko olla yhdistetty solu?
välttämättä koodissa ei tartte valita eikä aktivoida mitään jos tehdään esi. laskutoimituksia yms. soluille tai solualueelle
Mikä on edellinen koodi makrossa , joka aktivoi taulukon.?
Toimiiko ko. makro jossain toisessa työkirjassa - avaa uusi työkirja ja kokeile koodia.

Kyllä toi koodisi pitäisi toimia...
kokeile seuraavia variaatioita

Sheets("Sheet1"). Activate
Range("A1").Select

tai
Sheets("Sheet1"). Activate
Sheets("Sheet1").Range("A1").Select

tai
Application.GoTo Sheets("Sheet1").Range("A1")

toimiiko noilla?
taulukon moduuliin...
muuta kuvien polku ja tiedostotyyppi sekä kuvan koko sopivaksi
nyt lisää kuvat sarakkeen A soluihin

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Not Target.Comment Is Nothing Then
Target.Comment.Delete
End If
Target.AddComment
Target.Comment.Shape.Fill.UserPicture "C:\" & Target & ".jpg"
Target.Comment.Shape.Height = 200
Target.Comment.Shape.Width = 200
End If
End Sub
Kunde ei tajunnut yhtään mitään...
voisitkos antaa esimerkin
mun koodihan tekee just niin kuin halusit
SHIFT+CTRL+D
;-)
oikea koodi- noi select rivit oli vain testejä varten...

Dim Alkusolut As Range
Dim Täyttöalue As Range
Set Alkusolut = Range(ActiveCell, ActiveCell.Offset(-1, 0))
Set Täyttöalue = Range(ActiveCell, ActiveCell.Offset(9, 0))
Alkusolut.AutoFill Destination:=Täyttöalue
End Sub
moduuliin...

Sub Automaattitäyttö()
'alkusolut = solut, joissaa on sarjantekoon tarvittavat tiedot eli aktiivinen solu ja sitä edeltävä solu ylöspäin
'voi olla myös vasemallla ,oikealla ylhäällä- pitää muuttaa offsetteja
'ActiveCell.Offset(9, 0)) nyt 10 solun sarja alaspäin- muuta lukua tarvittaessa
'liitä maro pikanäppäimeen TOOLS/MACRO/MACROS/OPTIONS ja liitä kirjain pikanäppäinyhdistelmaan SHIFT+CTRL+D
Dim Alkusolut As Range
Dim Täyttöalue As Range
Set Alkusolut = Range(ActiveCell, ActiveCell.Offset(-1, 0))
Alkusolut.Select
Set Täyttöalue = Range(ActiveCell, ActiveCell.Offset(9, 0))
Täyttöalue.Select
Alkusolut.AutoFill Destination:=Täyttöalue
End Sub
taulukon moduuliin...
muuttele sopivaksi

Private Sub Worksheet_Change(ByVal Target As Range)
'Sheet1 on projektipohja
'solu A1=projektin nimi
'kopioi ennen koontitaulukkoa(Koonti) pohjan ja nimeää sen solun A1 mukaan
'tyhjentää koonti taulukossa A-sarakkeen ja täyttää tiedot projektien solusta A2 allekkain
'tyhjentää projektin nimen ja aktivoi projektinimi solun
Dim vastaus As Long
Dim lkm As Long
On Error GoTo virhe
Application.DisplayAlerts = False
Application.EnableEvents = False
If Not Intersect(Target, Range("A1")) Is Nothing Then
Worksheets("Sheet1").Copy Sheets(Sheets.Count)
ActiveSheet.Name = Range("Sheet1!A1")
End If

poistu:
Worksheets("Koonti").Range("A:A") = ""
For lkm = 2 To Worksheets.Count - 1
Worksheets(lkm).Range("A2").Copy Worksheets("Koonti").Range("A65536").End(xlUp).Offset(1, 0)
Next
Worksheets("Sheet1").Activate
Range("A1") = ""
Range("A1").Select
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub

virhe:
MsgBox "Samanniminen projekti oln jo olemassa!"
Worksheets(Worksheets.Count - 1).Delete
GoTo poistu
End Sub
sama offseteilla

Sub Siirrä()
Range("A1,A3,A5").Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft).Offset(0, 1)
Range("A1,A3,A5") = ""
End Sub

Sub Siirrä2()
Selection.Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft).Offset(0, 1)
Selection = ""
Range("A1").Select
End Sub
44 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt