Haasteellinen VBA koodi

Miten me pärjättiin ennekuin meillä oli @Kunde?

Kiitokset hyvästä koodinpätkästä. En kuitenkaan onnistut asiassa. En ymmärrä miksi ei hae tietoa, vaikka kokeilin sekä kahta että kolmea hakua.

Moduulissa ei näy virheitä, joten koodi kyllä sinänsä kunnossa, en vain osaa lukemalla tulkita mikä vialla.

Sub deeyksDirectory()

'tässä kansiossa olevat tiedot eivät täsmää muiden kanssa, alkaa G28 solusta etteenpäin.

Alla yksi hakujuttu minkä joskus löysin....

Dim Path As String
Dim FileName As String
Dim tWB As Workbook
Dim tWS As Worksheet
Dim mWB As Workbook
Dim aWS As Worksheet
Dim RowCount As Long
Dim uRange As Range


Path = "I:\Ohjeet\Keko-ohjeet exel\Vaihe D01\" 'Vaihda tähän oikea sheetti numero

Application.EnableEvents = False
Set mWB = Workbooks.Add(1)
Set aWS = mWB.ActiveSheet
If Right(Path, 1) Application.PathSeparator Then
Path = Path & Application.PathSeparator
End If
FileName = Dir(Path & "*.xls", vbNormal)
Do Until FileName = ""
Set tWB = Workbooks.Open(FileName:=Path & FileName)
For Each tWS In tWB.Worksheets
Set uRange = tWS.Range("g28", tWS.Cells(tWS.UsedRange.Row tWS.UsedRange.Rows _
.Count - 1, tWS.UsedRange.Column tWS.UsedRange.Columns.Count - 1))
If RowCount uRange.Rows.Count > 65536 Then
aWS.Columns.AutoFit
Set aWS = mWB.Sheets.Add(After:=aWS)
RowCount = 0
End If
If RowCount = 0 Then
aWS.Range("G28", aWS.Cells(1, uRange.Columns.Count)).Value = _
tWS.Range("G28", tWS.Cells(1, uRange.Columns.Count)).Value
RowCount = 1
End If
aWS.Range("A" & RowCount 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
= uRange.Value
RowCount = RowCount uRange.Rows.Count
Next
tWB.Close False
FileName = Dir()
Loop
aWS.Columns.AutoFit
mWB.Sheets(1).Select
Application.EnableEvents = True
End Sub

Avuton SEARCHH kirjoitti:

Kiitokset hyvästä koodinpätkästä. En kuitenkaan onnistut asiassa. En ymmärrä miksi ei hae tietoa, vaikka kokeilin sekä kahta että kolmea hakua.

Moduulissa ei näy virheitä, joten koodi kyllä sinänsä kunnossa, en vain osaa lukemalla tulkita mikä vialla.

Sub deeyksDirectory()

'tässä kansiossa olevat tiedot eivät täsmää muiden kanssa, alkaa G28 solusta etteenpäin.

Alla yksi hakujuttu minkä joskus löysin....

Dim Path As String
Dim FileName As String
Dim tWB As Workbook
Dim tWS As Worksheet
Dim mWB As Workbook
Dim aWS As Worksheet
Dim RowCount As Long
Dim uRange As Range


Path = "I:\Ohjeet\Keko-ohjeet exel\Vaihe D01\" 'Vaihda tähän oikea sheetti numero

Application.EnableEvents = False
Set mWB = Workbooks.Add(1)
Set aWS = mWB.ActiveSheet
If Right(Path, 1) Application.PathSeparator Then
Path = Path & Application.PathSeparator
End If
FileName = Dir(Path & "*.xls", vbNormal)
Do Until FileName = ""
Set tWB = Workbooks.Open(FileName:=Path & FileName)
For Each tWS In tWB.Worksheets
Set uRange = tWS.Range("g28", tWS.Cells(tWS.UsedRange.Row tWS.UsedRange.Rows _
.Count - 1, tWS.UsedRange.Column tWS.UsedRange.Columns.Count - 1))
If RowCount uRange.Rows.Count > 65536 Then
aWS.Columns.AutoFit
Set aWS = mWB.Sheets.Add(After:=aWS)
RowCount = 0
End If
If RowCount = 0 Then
aWS.Range("G28", aWS.Cells(1, uRange.Columns.Count)).Value = _
tWS.Range("G28", tWS.Cells(1, uRange.Columns.Count)).Value
RowCount = 1
End If
aWS.Range("A" & RowCount 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
= uRange.Value
RowCount = RowCount uRange.Rows.Count
Next
tWB.Close False
FileName = Dir()
Loop
aWS.Columns.AutoFit
mWB.Sheets(1).Select
Application.EnableEvents = True
End Sub

Lue lisää

hipsaa koodissa seuraava rivi ja testaa tuleeko virheilmoitusta, jos tulee niin mika?
On Error Resume Next

P.S. olen taasen yllapidon bannissa ja en pysty vastaamaan kuin naista internet kahviloista.
Kiitos bannista yllapito, vois ainakin syyn ilmoittaa- liikaa vastattu lienee

kundepuu kirjoitti:

hipsaa koodissa seuraava rivi ja testaa tuleeko virheilmoitusta, jos tulee niin mika?
On Error Resume Next

P.S. olen taasen yllapidon bannissa ja en pysty vastaamaan kuin naista internet kahviloista.
Kiitos bannista yllapito, vois ainakin syyn ilmoittaa- liikaa vastattu lienee

Lue lisää

Ilmoittaa " run-time error"445" -> object doesn´t support this action.

Debug jää kohtaan -> With Application.FileSearch

Alla vielä koodi, näkyy mitä muutin. En ymmärtänyt noita haku arvoja, koitin siis laittaa "osa1" tilalle haettavan tiedon? Aluksi laitoin ne sheet 1:lle soluun a1 ja a2. Koodi putsasi ne sieltä pois...

Sub Hae()
Dim i As Integer
Dim wb As Workbook
Dim laskuri As Integer
'On Error Resume Next
Application.ScreenUpdating = False
Range("A:A") = ""

With Application.FileSearch
.NewSearch
.LookIn = "I:\Ohjeet\Keko-ohjeet exel\Vaihe E07"
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
For i = 1 To .FoundFiles.Count
laskuri = 0
Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
If Not Etsi("836766123") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("598359850") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("Osa3") Is Nothing Then
laskuri = laskuri 1
End If
wb.Close
'If laskuri = 3 Then
If laskuri = 3 Or laskuri = 2 Then
Range("A65536").End(xlUp).Offset(1, 0) = .FoundFiles(i)
End If

Next i
End With
Application.ScreenUpdating = True
End Sub

Haasteeton kirjoitti:

Ilmoittaa " run-time error"445" -> object doesn´t support this action.

Debug jää kohtaan -> With Application.FileSearch

Alla vielä koodi, näkyy mitä muutin. En ymmärtänyt noita haku arvoja, koitin siis laittaa "osa1" tilalle haettavan tiedon? Aluksi laitoin ne sheet 1:lle soluun a1 ja a2. Koodi putsasi ne sieltä pois...

Sub Hae()
Dim i As Integer
Dim wb As Workbook
Dim laskuri As Integer
'On Error Resume Next
Application.ScreenUpdating = False
Range("A:A") = ""

With Application.FileSearch
.NewSearch
.LookIn = "I:\Ohjeet\Keko-ohjeet exel\Vaihe E07"
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
For i = 1 To .FoundFiles.Count
laskuri = 0
Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
If Not Etsi("836766123") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("598359850") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("Osa3") Is Nothing Then
laskuri = laskuri 1
End If
wb.Close
'If laskuri = 3 Then
If laskuri = 3 Or laskuri = 2 Then
Range("A65536").End(xlUp).Offset(1, 0) = .FoundFiles(i)
End If

Next i
End With
Application.ScreenUpdating = True
End Sub

Lue lisää

arvaan, luulen tietavani -TIEDAN
kaytossssi on siis EXCEL 2007...
siinapa onkin poistettu tuo filesearch objekti ...
joten muutettuna esim...

Option Explicit
Dim wb As Workbook
Dim polku As String
Dim nimi As Variant
Dim laskuri As Integer
Public ty๖kirja As String
Sub a()
'On Error Resume Next
Application.ScreenUpdating = False
Range("A:A") = ""
polku = "C:\Kokeilu\"
nimi = Dir(polku)
Do While nimi ""
Set wb = Workbooks.Open(Filename:=polku & nimi)
ty๖kirja = nimi
laskuri = 0
If Not Etsi("Osa1") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("Osa2") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("Osa3") Is Nothing Then
laskuri = laskuri 1
End If
wb.Close
'If laskuri = 3 Then
If laskuri = 3 Or laskuri = 2 Then
Range("A65536").End(xlUp).Offset(1, 0) = polku & nimi
End If
nimi = Dir
Loop
Application.ScreenUpdating = True
End Sub
Function Etsi(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String

Workbooks(ty๖kirja).Activate
Workbooks(ty๖kirja).Worksheets("Taul1").Activate
With Range("L2:L50")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
End If
End With

End Function

Kundepuu alias Kunde kirjoitti:

arvaan, luulen tietavani -TIEDAN
kaytossssi on siis EXCEL 2007...
siinapa onkin poistettu tuo filesearch objekti ...
joten muutettuna esim...

Option Explicit
Dim wb As Workbook
Dim polku As String
Dim nimi As Variant
Dim laskuri As Integer
Public ty๖kirja As String
Sub a()
'On Error Resume Next
Application.ScreenUpdating = False
Range("A:A") = ""
polku = "C:\Kokeilu\"
nimi = Dir(polku)
Do While nimi ""
Set wb = Workbooks.Open(Filename:=polku & nimi)
ty๖kirja = nimi
laskuri = 0
If Not Etsi("Osa1") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("Osa2") Is Nothing Then
laskuri = laskuri 1
End If
If Not Etsi("Osa3") Is Nothing Then
laskuri = laskuri 1
End If
wb.Close
'If laskuri = 3 Then
If laskuri = 3 Or laskuri = 2 Then
Range("A65536").End(xlUp).Offset(1, 0) = polku & nimi
End If
nimi = Dir
Loop
Application.ScreenUpdating = True
End Sub
Function Etsi(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String

Workbooks(ty๖kirja).Activate
Workbooks(ty๖kirja).Worksheets("Taul1").Activate
With Range("L2:L50")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
End If
End With

End Function

Lue lisää

Loistavaa työskentelyä kunde.

Suuret kiitokset.

Jos vielä yksi pikku juttu. Voiko tämän osa1 "If Not Etsi("Osa1") Is Nothing Then" kohdan saada esim. activesheet cellvalueksi jotenkin "If Not Etsi("activesheet.Cellvalue.Taul1!B1") Is Nothing Then
?

EIvaan osaa kirjoitti:

Loistavaa työskentelyä kunde.

Suuret kiitokset.

Jos vielä yksi pikku juttu. Voiko tämän osa1 "If Not Etsi("Osa1") Is Nothing Then" kohdan saada esim. activesheet cellvalueksi jotenkin "If Not Etsi("activesheet.Cellvalue.Taul1!B1") Is Nothing Then
?

Lue lisää

If Not Etsi(Range("B1")) Is Nothing ...