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
- ei oo tullut postia?
- ainahan ehta tiedosto on asiaa
laita muutama mallitiedosto ja excel tiedosto mulle emailiin kunde.khorat (at )hotmail.com - Voitko laittaa malli tiedoston rakeenteesta ja mitä haetaan.
Haetaanko aina vaan malli sanaa ja sen jatkoja vai pitääkö pystyä hakemaan muitakin vaihtoehtoja ?
Pitääkö pystyä lukemaan molemmat lennossa vaiko jompikumpi vaan? - tottakai saa ja on mun tekemä koodikin täällä
- Miksi sitä kaikkea tietoa tarvitsee tuoda, jos kerran 3 riviä vaan tarvitaan joka sivulta. Eli luetaan tiedostosta vaan ne tarvittavat 3 rivin tiedot sivuttain....
Keep EXCELing
@Kunde - https://www.youtube.com/watch?v=lAykFf9mXN0
Keep EXCELing
@Kunde - Ongelmana sulla on Excelin volative functions.
Jos haluat päästä eroon sun pitää tehdä oma funktio(UDF).
Googleta Excel volative functions.
Tossa mikkiksen oma tarina asiasta(epätäydellinen noiden volative functions kanssa kuiteskin ) ;-)
https://msdn.microsoft.com/en-us/library/office/bb687891.aspx - Muuttele nimet ja polut oikeaksi
Sub Makro1()
Dim polku As String
Dim tiedostonnimi As String
Dim lähde As Workbook
polku = "C:\"
tiedosto = "malli_02"
Worksheets("Taul1").Range("A:P") = ""
Set lähde = Workbooks.Open(polku & tiedosto)
ThisWorkbook.Worksheets("Taul1").Range("A1:P1000").Value = lähde.Sheets("Taul1").Range("A1:P1000").Value
lähde.Close False
Range("A1").Select
ActiveWorkbook.Worksheets("Taul1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Taul1").Sort.SortFields.Add Key:=Range("A1:A20"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Taul1").Sort
.SetRange Range("A1:P1000")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub Makro2()
Worksheets("Taul1").Range("A:P") = ""
Worksheets("Taul1").Range("A1:P1000").Value = Worksheets("Taul2").Range("A1:P1000").Value
Range("A1").Select
ActiveWorkbook.Worksheets("Taul1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Taul1").Sort.SortFields.Add Key:=Range("A1:A20"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Taul1").Sort
.SetRange Range("A1:P1000")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub Makro3()
Dim vika As Long
Dim löydetty As Range
Dim löydetty2 As Range
Dim polku As String
Dim tiedostonnimi As String
Dim lähde As Workbook
Dim solu As Range
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Huuhaa").Delete
On Error GoTo virhe
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Huuhaa"
polku = "C:\"
tiedosto = "malli_04"
Set lähde = Workbooks.Open(polku & tiedosto)
ThisWorkbook.Worksheets("Huuhaa").Range("F1:I1000").Value = lähde.Sheets("Taul1").Range("A1:D1000").Value
lähde.Close False
ThisWorkbook.Worksheets("Taul1").Range("A1:D1000").Copy Worksheets("Huuhaa").Range("A1:D1000")
With Worksheets("Huuhaa").Range("E1")
.FormulaR1C1 = "=RC[-4]&RC[-3]&RC[-1]"
.AutoFill Destination:=Range("E1:E20")
End With
With Worksheets("Huuhaa").Range("J1")
.FormulaR1C1 = "=RC[-4]&RC[-3]&RC[-1]"
.AutoFill Destination:=Range("J1:J20")
End With
vika = Worksheets("Huuhaa").Range("J65536").End(xlUp).Row
For Each solu In Worksheets("Huuhaa").Range("J1:J" & vika)
Set löydetty = EtsiJaSiirrä(solu, Columns("E:E"))
If Not löydetty Is Nothing Then
If löydetty2 Is Nothing Then
Set löydetty2 = löydetty
Else
Set löydetty2 = Union(löydetty2, löydetty)
End If
End If
Next
Worksheets("Taul1").Range(löydetty2.Address).EntireRow.Delete
virhe:
ThisWorkbook.Worksheets("Huuhaa").Delete
Application.DisplayAlerts = True
End Sub
Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Huuhaa").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
Keep EXCELing
@Kunde - tämmösen funktiohan ei palauta mitään... ;-)
luvun tai lukujen välissä voi olla tyhjiäkin. Kyssäristä ei käy ilmi voiko olla desimaaleja yms ?
Sub Testi()
MsgBox HaeLuku("222227 cm")
End Sub
Public Function HaeLuku(s As String) As Variant
HaeLuku = Trim(Mid(StrReverse(s), 3))
If IsNumeric(HaeLuku) Then
HaeLuku = StrReverse(HaeLuku)
Else
HaeLuku = "VIRHE"
End If
End Function
Keep EXCELing
@Kunde - Juuri noin, kuten enosaavba kirjoittaa...
Sub Tsekkaapäiväykset()
Dim vika As Long
vika = Range("A65536").End(xlUp).Row
For i = vika To 2 Step -1
'¨muuta sarake oikeaksi 1= A-sarake, 2=B-sarake jne.
If Cells(i - 1, 1).Value <> Cells(i, 1).Value Then
Cells(i, 1).EntireRow.Insert
'Cells(i, 1).Insert
End If
Next i
End Sub
Keep EXCELing
@Kunde - Sub Tsekkaapäiväykset()
Dim vika As Long
vika = Range("A65536").End(xlUp).Row
For i = vika To 2 Step -1
'¨muuta sarake oikeaksi 1= A-sarake, 2=B-sarake jne.
If Cells(i - 1, 1).Value <> Cells(i, 1).Value Then
Cells(i, 1).Insert
End If
Next i
End Sub
Keep EXCELing
@Kunde - Function EtsiJaSiirrä2(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Data").Activate
With Range("D:D")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
EkaOsoite = solu.Address
If UCase(solu.Offset(0, -1)) = "C" Then
Set EtsiJaSiirrä2 = solu.Offset(0, -2)
Set EtsiJaSiirrä2 = Union(EtsiJaSiirrä2, solu.Offset(0, 1))
End If
Do
Set solu = .FindNext(solu)
If UCase(solu.Offset(0, -2)) = "C" Then
If EtsiJaSiirrä2 Is Nothing Then
Set EtsiJaSiirrä2 = solu.Offset(0, 1)
Else
Set EtsiJaSiirrä2 = Union(EtsiJaSiirrä2, solu.Offset(0, 1))
End If
End If
Loop While Not solu Is Nothing And solu.Address <> EkaOsoite
End If
End With
End Function
Sub Testi2()
Dim Löydetty As Range
Dim solu As Range
On Error GoTo virhe
Set Löydetty = EtsiJaSiirrä2("X")
Worksheets("Yhteenveto").Range("B2:B10000") = ""
Löydetty.Copy Range("Yhteenveto!B65536").End(xlUp).Offset(1, 0)
Exit Sub
virhe:
MsgBox "Hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub
Keep EXCELing
@Kunde - Edelleen kuulostaa tosi tehottomalta ratkaisulta ;-)
jos tietosi on A1-A300 niin if cells(i,1)="" then exit sub toimii, muuten pitää muuttaa
vastaamaan alkavaa solua tyyliin if cells(99 i,1)="" then exit
missä 99 i on aloitussolu eli tässä tapauksessa A100
ja jos eri sarake kuin A esim B niin cells(99 i,2) eli B100
Keep EXCELing
@Kunde - Miksi loopata 300 kertaa ja kutsua makroa kun sen voi kutsua vain kerran ja tehdä jutut?
- Sub LisääJokatoka()
Dim vika As Long
Dim i As Long
vika = Range("C65536").End(xlUp).Row
For i = 3 To 746 Step 2
Columns(i).Insert Shift:=xlToRight
Next
For i = 5 To 746 Step 2
' vähentää nyt ylemmästä alemman, jos toistepäin niin hipsaa allaoleva kaava ja poista hipsu seuraavalta riviltä
Range(Cells(2, i), Cells(vika, i)).FormulaR1C1 = "=R[-1]C[-1]-RC[-1]"
'Range(Cells(2, i), Cells(vika, i)).FormulaR1C1 = "=RC[-1]-R[-1]C[-1]"
Next
End Sub
Keep EXCELing
@Kunde - luin vain kyssäri huolimattomasti tsekkasin koodin...
tsekka luupin max arvo onko oikein?
Sub LisääJokatoka()
Dim i As Long
For i = 3 To 746 Step 2
Columns(i).Insert Shift:=xlToRight
Next
End Sub
Keep EXCELing
@Kunde - kuten sanoit vaatii yksinkertaisemman makron... ;-)
Range("C1:ABR1").Insert Shift:=xlToRight
Keep EXCELing
@Kunde - piece of the cake koodilla....
Keep EXCELing
@Kunde - ei ne häviä mihinkään jos oikein asiat tekee.
Viedessä soluissa pitää olla oikeat muotoilut ja kun tuo niin apuna käyttää tuontivelhoa tai makroa ja muistaa määritellä kentille oikeat muotoilut ja taatusti kaikki on OK
Keep EXCELing
@Kunde - odotellaan seuraavaa varmasti tulevaa bugia ;-)...
Keep EXCELing
@Kunde