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
oletuksena otsikot ekalla rivillä ja 4 saraketta tietoa.
helppo muutella toki...

Sub Transponoi()
Dim vika As Integer
Dim solu As Range
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("A2:A" & vika)
solu.Resize(1, 11).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Range("A2").Select
For i = 1 To vika - 1
Worksheets(originaali.Name).Range("A1:D1").Copy
Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Application.CutCopyMode = False
End Sub

Keep EXCELing
@Kunde
en tiedä ymmärsinkö oikein, ja mitä niistä koodeista olis pitänyt muokata(muokkasin nyt ekaa versiota)?
Nyt aktiivinen taulukko kopioituu aina aina uuteen taulukkoon, joka lisätään loppuun

"Lisäarvoa tulisi myös siitä, että taulukon sarakenimet kopioituisivat transponoitujen arvojen vasemmalla olevaan sarakkeeseen."
Tota en ymmärtänyt...

Sub Transponoi()
Dim vika As Integer
Dim solu As Range
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("A1:A" & vika)
solu.Resize(1, 11).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Application.CutCopyMode = False
End Sub

Keep EXCELing
@Kunde
se lontoon versiossa...
suomiversio
=POIMI.TEKSTI(SOLU("tiedostonnimi");ETSI("]";SOLU("tiedostonnimi"))+1;255)
pari päivää sitten vastasin samanlaiseen kyssäriin...

http://keskustelu.suomi24.fi/node/9654096
mutta aikaa ja kahvia menee...
nyt et kerkiä hörpätä edes kahvia kun jo valmis ;-)

ei ole virhetarkasteluja eikä muitakaan "säätöjä", joten makro "kaatuu", jos on jo ennestään saman niminen taulukko (eli raporttixx).

Sub LisääTaulukko()
For i = 1 To 200
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
taulukko.Name = "raportti" & i
Set taulukko = Nothing
Next i
End Subub
aktiivisen taulukon saa funktiolla
=MID(CELL("filename");FIND("]";CELL("filename"))+1;255
muut taulukot sitten hankalaa räpeltämistä... esim laittamalla saman koodin muihin taulukoihin samaan soluun ja sitten linkittöö sen solun jne...

VBa siisti ja simppeli aktiiviseen taulukkoon alkaen solusta A1

Sub TaulukonNimet()
For i = 1 To Sheets.Count
Range("A" & i) = Sheets(i).Name
Next i
End Sub

tai omana funktiona soluun haluttu taulukon nimi esim. ==TaulukonNimi(1)

Function TaulukonNimi(Indeksi As Integer) As String
On Error GoTo virhe
TaulukonNimi = Sheets(Indeksi).Name
Exit Function
virhe:
TaulukonNimi = "Ei tietoa???"
End Function

Keep EXCELing
@Kunde
oma solumuotoilu esim. ppp lyhyenä ma,ti,ke.. ja pppp maanantai,tiistai,keskiviikko
Sub Siirrä()
Dim vika As Long
vika = Range("A65536").End(xlUp).Row
Sheets("Sheet1").Activate
For Each solu In Range("A2:A" & vika)
session.findById("wnd[0]").maximize
session.findById("wnd[0]/mbar/menu[1]/menu[3]").Select
session.findById("wnd[0]/usr/ctxt[0]").Text = solu.Offset(0, 1)
session.findById("wnd[0]/usr/ctxt[4]").Text = solu
session.findById("wnd[0]/usr/ctxt[4]").SetFocus
session.findById("wnd[0]/usr/ctxt[4]").caretPosition = 7
session.findById("wnd[0]").sendVKey 0
Next
MsgBox "ALL " & vika - 1 & " Excel rows processed"
End Sub

Keep EXCELing
@Kunde
lisäsin malliksi aikamuotoilun, jota on helppo muotoilla...

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Range("A1:A200"), Target) Is Nothing Then
If Not Target = "" Then
Target.Offset(0, 1) = Format(Now(), "dd.mm.yyyy hh:mm:ss")
End If
End If
End Sub
tietämättä tarpeitasi tossa alla yleisluontoinen esim.
eli tsekataan A2 solua ja kun soluun syötetään arvo, niin soluun B2 tulee kellonaika. Tee soluun B2 sopiva solumuotoilu.
Solun B2 arvo ei muutu, vaikka muut solut muuttusivatkin toisin kuin noilla volatile eli ei pysyvillä Excelin omilla funktioilla.
Solun B2 arvo muuttuu vain siinä tapauksessa, kun solu A2 on tyhjennetty ja uudelleen syötetään arvo siihen

taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("A2"), Target) Is Nothing Then
If Not Range("A2") = "" Then
Range("B2") = Now()
End If
End If
End Sub

Keep EXCELing
@Kunde
jos ei ole muita objekteja käytössä kuin kuvia, niin onnistuu kuvan poisto myös ilman koodia
EDIT/ Go To/avautuvassa valikossa Special ja edelleen avautuvasta valikossa ruksi ruutuun Objects
Ok ja delete
poistaa aktiivisesta taulukosta kuvat

moduuliin...

Sub PoistaKuvat()
For Each Picture In ActiveSheet.Pictures
Picture.Delete
Next
End Sub

Keep EXCELing
@Kunde
kaikkeahan saa luettua ja kirjoiteltua koodilla. Eri asia sitten miten ne saa päiviteltyä helposti, kun Wordissa ei ole valmiina tapahtumille koodia ja ne pitää sitten itse väsäillä.
Helpoimmalla sun tapauksessahan olisi päässsyt koodaamalla kirjainmerkkiin, mutta kun nyt halusit kenttään niin olkoon menneeksi...

liitä koodit Normal.dot ThisWorkbook moduuliin ja koodit on sitten aina käytössäsi ilman uudelleen kirjoittamista...
Voit tehdä napit helpottamaan elämääsi ja liittää koodit niihin.

Nyt kun ajat koodin Lisää() se lisää kenttäluettelon DocProperty nimen ominaisuuksiin Kuvienlkm.
Eli Kuvienlkm toimii ihan kuten normaalitkin ominaisuudet(löytyy listasta) ja lisää kenttään koodin
{DOCPROPERTY Kuvienlkm \* MERGEFORMAT}

Päivitys ei oikein ole Wordin vahvoja puolia, joten sekin sitten koodilla Päivitä()...

Sub Päivitä()
Dim jutska As Range
Dim kenttä As Field
Dim objCustomProperties As DocumentProperties
Set objCustomProperties = ActiveDocument.CustomDocumentProperties
objCustomProperties.Item("Kuvienlkm").Value = ActiveDocument.InlineShapes.Count

For Each jutska In ActiveDocument.StoryRanges
For Each kenttä In jutska.Fields
kenttä.Update
Next kenttä
Next jutska
Set jutska = Nothing
Set kenttä = Nothing
End Sub

Sub Lisää()
Dim objCustomProperties As DocumentProperties
On Error Resume Next
Set objCustomProperties = ActiveDocument.CustomDocumentProperties
objCustomProperties.Add Name:="Kuvienlkm", Type:=msoPropertyTypeString, Value:=ActiveDocument.InlineShapes.Count, LinkToContent:=False
End Sub

Keep WORDing
@Kunde
Sub Transponoi()
Dim vika As Long
Dim vika2 As Long
Dim solu As Range
On Error Resume Next
Application.ScreenUpdating = False
Worksheets("Taul2").Range("B:B") = ""
vika = Range("Taul1!A65536").End(xlUp).Row
vika2 = Range("Taul1!C65536").End(xlUp).Row
If vika < vika2 Then
vika = vika2
End If
For Each solu In Range("A1:A" & vika)
solu.Copy
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
If Not solu.Offset(0, 2).Text = "#N/A" Then
solu.Offset(0, 2).Copy
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Keep EXCELling
@Kunde
Sub Transponoi()
Dim vika As Long
Dim vika2 As Long
Dim solu As Range
On Error Resume Next
Application.ScreenUpdating = False
Worksheets("Taul2").Range("B:B") = ""
vika = Range("Taul1!A65536").End(xlUp).Row
vika2 = Range("Taul1!C65536").End(xlUp).Row
If vika < vika2 Then
vika = vika2
End If
For Each solu In Range("A1:A" & vika)
solu.Copy
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
solu.Offset(0, 2).Copy
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub Transponoi()
Dim vika As Long
Dim vika2 As Long
Dim solu As Range
Worksheets("Taul2").Range("B:B") = ""
vika = Range("Taul1!A65536").End(xlUp).Row
vika2 = Range("Taul1!C65536").End(xlUp).Row
If vika < vika2 Then
vika = vika2
End If
For Each solu In Range("A1:A" & vika)
solu.Copy Range("Taul2!B65536").End(xlUp).Offset(1, 0)
solu.Offset(0, 2).Copy Range("Taul2!B65536").End(xlUp).Offset(1, 0)
Next
Application.CutCopyMode = False
End Sub
Sub Transponoi()
Dim vika As Integer
Dim solu As Range
Worksheets("Taul2").Range("B:B") = ""
vika = Range("Taul1!A65536").End(xlUp).Row
For Each solu In Range("Taul1!A1:C" & vika)
solu.Copy
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Application.CutCopyMode = False
End Sub
Sub Transponoi()
Dim vika As Integer
Dim solu As Range

Worksheets("Taul2").Range("B:B") = ""

'a- sarake
vika = Range("Taul1!A65536").End(xlUp).Row
For Each solu In Range("Taul1!A1:A" & vika)
solu.Copy
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next

'c sarake
vika = Range("Taul1!C65536").End(xlUp).Row
For Each solu In Range("Taul1!C1:C" & vika)
solu.Copy
Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next

Application.CutCopyMode = False
End Sub

Keep EXCELling
@Kunde
haetaanko avoimesta vaiko suljetusta tiedostosta?
Yhdestä vaiko monesta tiedostosta?
Yhdestä vaiko monesta taulukosta
Mitä haetaan ja minkälainen on hakualueen rakenne...

Keep EXCELling
@Kunde
Sub LAskeTyhjätVälit2()
Dim vika As Long
Dim i As Long
Dim rivi As Long
Dim tulos As String

Range("AH:AH").Clear

For rivi = 5 To 370

vika = Range("IV" & rivi).End(xlToLeft).Column

For i = 2 To Range(Cells(5, 5), Cells(5, vika)).SpecialCells(xlCellTypeBlanks).Areas.Count
tulos = tulos & Range(Cells(5, 5), Cells(5, vika)).SpecialCells(xlCellTypeBlanks).Areas(i).Cells.Count & ", "
Next

If Not tulos = "" Then
Range("AH" & rivi) = Left(tulos, Len(tulos) - 2)
tulos = ""
End If

Next
Range("AH:AH").NumberFormat = "@"
Range("AH:AH").EntireColumn.AutoFit
End Sub

Keep Excelling
@Kunde
38 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt