kunde

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

Aloituksia

7

Kommenttia

1377

  1. ThisWorkbook moduuliin...

    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    ActiveWorkbook.SaveAs "C:/sdtilaus" & Range("A1") & ".xls"
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Cancel = True
    End Sub
  2. moduuliin...

    Sub MuutaLuvuksi()
    With Range("B6:AA100")
    .NumberFormat = 0
    .Value = .Value
    End With
    End Sub
  3. nyt lähes normaali toiminnat...
    leikkaa heti kun valitaan solu...
    paste special ei toimi tietenkään...

    katotaan saako paremmaksi vielä

    viittaus Microsoft Forms 2.0 Object Libraryyn

    ThiWorkbook moduuliin...

    Option Explicit
    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    Static Vanha As Range
    Static kopiointi As Integer
    On Error Resume Next
    kopiointi = Application.CutCopyMode
    If Not Vanha Is Nothing Then
    Vanha.EntireRow.Interior.ColorIndex = xlColorIndexNone
    End If
    Target.EntireRow.Interior.ColorIndex = 15
    If kopiointi = 1 Then
    Leikepöytä (AlueLeikepöytä(Vanha))
    End If
    If kopiointi = 2 Then
    Leikepöytä (AlueLeikepöytä(Vanha))
    Vanha = ""
    End If
    Set Vanha = Target
    End Sub

    tavalliseen moduuliin...
    Option Explicit
    Option Compare Text
    Private DataObj As MSForms.DataObject
    Public Function Leikepöytä(S As String)
    On Error GoTo virhe:
    If DataObj Is Nothing Then
    Set DataObj = New MSForms.DataObject
    End If
    DataObj.SetText S
    DataObj.PutInClipboard
    Exit Function
    virhe:
    Exit Function
    End Function
    Public Function AlueLeikepöytä(Alue As Range) As String

    Dim Rivi As Long
    Dim Sarake As Long
    Dim Teksti As String
    For Rivi = 1 To Alue.Rows.Count
    For Sarake = 1 To Alue.Columns.Count
    Teksti = Teksti & Alue(Rivi, Sarake).Value & _
    IIf(Sarake < Alue.Columns.Count, vbTab, vbNullString)
    Next Sarake
    Teksti = Teksti & IIf(Rivi < Alue.Rows.Count, vbNewLine, vbNullString)
    Next Rivi
    AlueLeikepöytä = Teksti
    End Function
  4. kopioi/liittää aktiiviseen soluun kopioidun/leikatun alueen.

    ThisWorkbook moduuliin...

    Option Explicit
    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    Static Vanha As String
    On Error Resume Next
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    If Application.CutCopyMode = 1 Then
    Range(Vanha).Copy Target
    End If
    If Application.CutCopyMode = 2 Then
    Range(Vanha).Copy Range(Target.Address)
    Range(Vanha) = ""
    End If
    Cells.EntireRow.Interior.ColorIndex = xlColorIndexNone
    Target.EntireRow.Interior.ColorIndex = 15
    Vanha = Target.Address
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End Sub
  5. näköjään tyhjentää leikepöydän sisällön...
  6. mielenkiintoinen ilmiö...
    ei äkkiseltään kyllä keksi mikä ton aiheuttaa, mutta tsekataan
  7. moduuliin...

    Sub KopioiEiTyhjätrivit()
    Dim Kopioitavat As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
    For Each solu In Range("A10:A20")
    If Application.CountA(solu.EntireRow) > 0 Then
    If Kopioitavat Is Nothing Then
    Set Kopioitavat = solu.EntireRow
    Else
    Set Kopioitavat = Union(Kopioitavat, solu.EntireRow)
    End If
    End If
    Next
    Sheets("Sheet2").Rows("1:21").Clear
    Kopioitavat.Copy Sheets("Sheet2").Range("A1")
    Application.ScreenUpdating = True
    End Sub
  8. tee testi tyyli ja koodi ThisWorkbook moduuliin...

    Option Explicit
    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    Static Vanha As Range
    On Error Resume Next
    If Not Vanha Is Nothing Then
    Vanha.EntireRow.Interior.ColorIndex = xlColorIndexNone
    End If
    Target.EntireRow.Style = "testi"
    Set Vanha = Target
    End Sub
  9. YhisWorkbook moduuliin...
    Option Explicit
    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    Static Vanha As Range
    On Error Resume Next
    If Not Vanha Is Nothing Then
    Vanha.EntireRow.Interior.ColorIndex = xlColorIndexNone
    End If
    Target.EntireRow.Interior.ColorIndex = 15
    Set Vanha = Target
    End Sub
  10. missä järjestyksessä tiedot on ja mitä poistetaan yms...
    pieni esim. helpottaisi
  11. taulukon moduuliin...

    Private Sub ComboBox1_Click()
    Cells(ActiveCell.Row, 5) = ComboBox1.ListIndex + 1
    'jos haluat jättää valinnan näkyville hipsaa seuraava rivi
    ComboBox1.ListIndex = -1
    ActiveCell.Select
    End Sub
  12. ei kyllä tuota voi tehdä. Toi kelpoisuusehto toimii, jos laitat joka soluun kelpoisuusehdon, mutta kun pyydettiin...

    "Kohdesolu on aktiivisena olevan rivin ja sarake 5 mukainen solu."

    tuota ei voi tehdä ilman koodia
  13. taulukon moduuliin...

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ComboBox1.LinkedCell = Cells(Target.Row, 5).Address
    End Sub

    jaa noi muut jutut taitaakin olla ominaisuuksien oletusjuttuja
    ListRows=8
  14. comboboxin koodiin...

    Private Sub ComboBox1_Change()
    Range("A6") = ComboBox1.Column(0)
    Range("B6") = ComboBox1.Column(1)
    End Sub

    ja comboboxin ominaisuuksiin...
    ListFillRange=A3:B5
    ColumnCount=2
    LinkedCell arvon voit jättää pois...
    siinäpä se
  15. moduuliin...
    nyt tiedot alkaen riviltä 1, muuta sopivaksi

    Sub SiirräJaPoista()
    Dim vika As Integer
    On Error Resume Next
    vika = Range("A65536").End(xlUp).Row
    Range("A2:A" & vika).Cut Destination:=Range("A1:A" & vika - 1)
    Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    End Sub
  16. sorry kun muistanut et tulee noi lainausmerkit Excelillä...
    nyt kirjoittaa suoraan tekstitiedostoon...

    Sub Siirrä2()
    Dim vika As Integer
    Dim vapaa As Integer
    vika = Range("J65536").End(xlUp).Row
    vapaa = FreeFile()
    Open "C:\Acad.scr" For Output As vapaa
    For Each solu In Range("J4:J" & vika)
    Print #1, solu
    Next
    Close #1
    End Sub
  17. voisithan sitä acadiä ohjata suoraan excelistä ilman scriptiä...
    aika paljon tullut puljattua noitten kanssa...
    mutta tossa nyt yksi tapa

    Sub Siirrä()
    Dim vika As Integer
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    vika = Range("J65536").End(xlUp).Row
    Range("J4:J" & vika).Copy
    Workbooks.Add
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs Filename:="C:\acad.csr", FileFormat:=xlText
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub
  18. milläs meinasit käynnistää sheet2:lta makron?

    lisää moduuliin makro minkä haluat suoritettavan
    esim.
    Sub a()
    MsgBox "hei"
    End Sub

    sheet1 napin koodiin laitat

    Private Sub CommandButton1_Click()
    a
    End Sub

    ja sitten sheet2:lle vaikkapa hiiren oikealle napille

    Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Range("A1") = 1 Then
    a
    End If
    Cancel = True
    End Sub
  19. Sub Makro1()
    '
    ' Makro1 Makro
    '

    '
    Dim vika As Integer
    vika = Range("D65536").End(xlUp).Row
    Range("D18").Formula = "=D17+1"
    Range("D18").AutoFill Range("D18:D" & vika)
    End Sub
  20. Sub Makro1()
    '
    ' Makro1 Makro
    '

    '
    Dim vika As Integer
    vika = Range("D65536").End(xlUp).Row - 1
    Range("D18").Formula = "=D17+1"
    Range("D18").AutoFill Range("D18:D" & vika)
    End Sub
    21. 56 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt