Lijst van data die aan bepaalde voorwaarde voldoet

Status
Niet open voor verdere reacties.
E

edwin13387

Gebruiker
Lid geworden
12 jun 2015
Berichten
46
Hallo,

Ik heb weer geprobeert een stukje VBA te gebruiken wat ik op het forum vond, maar hij werkt niet.
Simpel gezegd: hij loopt vast.
Ik gok dus dat er ergens iets verkeert staat, waardoor excel eeuwig bezig is of zo.

Het voorbeeldbestand waar ik dit uit gepakt heb werkt, dus had ik goede hoop.
De voorwaarde en wat overige namen aangepast, maar niet succesvol.

Zou iemand de tijd hebben even te kijken?

(Indien ik iets fout heb gedaan, het doel:
Een extra sheet, met hierin de samples op het lab waar nog geen reactie op is ontvangen)

mvg
Edwin
Ik zou het liefst een oplossing hebben uit deze code, omdat ik het idee had deze enig sinds te begrijpen. Dan kan ik kijken waar ik de mist in ga.Bekijk bijlage blend log gisteren.xlsm
 
Maak van
Code: 
FactuurRij = FactuurRij + 1
eens
Code: 
SampleRij = SampleRij + 1
 
bedankt

Hallo,

Top dat was hem ja, zelf een draaiende macro krijg ik nog om zeep...
Nu nog een vraagje:
Code: 
Public RunWhen As Double
Public Const cRunIntervalSeconds = 900 ' 15 minutes
Public Const cRunWhat = "SaveFile"  ' the name of the procedure to run

Sub Auto_Open()

'  sub automatically ran upon opening the file
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
    Schedule:=True
End Sub


Sub SaveFile()
Dim Sh As Worksheet, Wb As Workbook, SampleRij As Integer, InvulRij As Integer
    InvulRij = 6
    Application.ScreenUpdating = False
Set Wb = Workbooks("blend log.xlsm")
    With Worksheets("Lab samples")
        .UsedRange.Offset(3).ClearContents   'oude gegevens verwijderen
        For Each Sh In Wb.Sheets
            If Not (Sh.Name = "Algemeen" Or _
                    Sh.Name = "Lab samples") Then
                SampleRij = 4
                Do Until Sh.Cells(SampleRij, 7) = ""
                    If Sh.Cells(SampleRij, 10) <> "" And Sh.Cells(SampleRij, 11) = "" And Sh.Cells(SampleRij, 12) = "" And Sh.Cells(SampleRij, 13) = "" Then
                        .Cells(InvulRij, 2) = Sh.Name
                        .Cells(InvulRij, 3) = Sh.Cells(SampleRij, 6)
                        .Cells(InvulRij, 4) = Sh.Cells(SampleRij, 10)
                        .Cells(InvulRij, 5) = Sh.Cells(SampleRij, 15)
                        InvulRij = InvulRij + 1
                    End If
                    SampleRij = SampleRij + 1
                Loop
            End If
            InvulRij = InvulRij + 1
        Next Sh
    End With
    Application.ScreenUpdating = True

'   check whether file is readonly, if so do nothing, else save file
If Workbooks("blend log.xlsm").ReadOnly = False Then
       
    Workbooks("blend log.xlsm").Save
    End If
    Auto_Open  ' Reschedule the procedure
End Sub

Sub StopTimer()

'  sub automatically ran upon closing the file
    On Error Resume Next
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
    Schedule:=False
End Sub
Dit is wat ik nu heb, ik had namelijk niet door dat in het origineel de macro gestart werdt door het openen van een tab.
Nu start hij uit zich zelf, alleen samen met de save. Kan dit los gemaakt worden door de omliggende macro's te copieeren? Ik heb dit geprobeert maar werkte niet, maar als dit zou moeten werken ga ik verder proberen.
Tevens nog een vraag: klopt het dat als deze macro draait, en je het wb niet gedimt hebt, de macro in het actieve excel bestant draait?

Bedankt,
Edwin
 
volgende vraag

Hallo,

Ik blijf vragen vinden:
Ik zou uit bestand 1, bepaalde cellen willen copieren naar bestand 2.
Dit in sheets met de zelfde naam.

Code: 
Sub Samplesgister()
Dim Wb As Workbook, Sh As Worksheet, wblog As Workbook, SampleRij As Integer, InvulRij As Integer
On Error Resume Next
Set Wb = Workbooks("blend log gisteren.xlsx")
If Wb Is Nothing Then Set Wb = Workbooks.Open("I:\OEE\testbestand\blend log gisteren.xlsx")
Set wblog = Workbooks("blend log.xlsm")
InvulRij = 4
For Each Sh In Wb.Sheets
    If Sh.Name = "Nieuwe blender" Or Sh.Name = "Oude blender" Or Sh.Name = "Hand blends en G-tanks" Then
    SampleRij = 4
        Do Until Sh.Cells(SampleRij, 7) = ""
        If Sh.Cells(SampleRij, 10) <> "" And Sh.Cells(SampleRij, 11) = "" And Sh.Cells(SampleRij, 12) = "" And Sh.Cells(SampleRij, 13) = "" Then
                        wblog.Cells(InvulRij, 2) = Sh.Cells(SampleRij, 2)
                        wblog.Cells(InvulRij, 3) = Sh.Cells(SampleRij, 3)
                        wblog.Cells(InvulRij, 4) = Sh.Cells(SampleRij, 4)
                        wblog.Cells(InvulRij, 5) = Sh.Cells(SampleRij, 5)
                        wblog.Cells(InvulRij, 6) = Sh.Cells(SampleRij, 6)
                        wblog.Cells(InvulRij, 7) = Sh.Cells(SampleRij, 7)
                        wblog.Cells(InvulRij, 8) = Sh.Cells(SampleRij, 8)
                        wblog.Cells(InvulRij, 9) = Sh.Cells(SampleRij, 9)
                        wblog.Cells(InvulRij, 10) = Sh.Cells(SampleRij, 10)
                        wblog.Cells(InvulRij, 11) = Sh.Cells(SampleRij, 11)
                        wblog.Cells(InvulRij, 12) = Sh.Cells(SampleRij, 12)
                        wblog.Cells(InvulRij, 13) = Sh.Cells(SampleRij, 13)
                        wblog.Cells(InvulRij, 14) = Sh.Cells(SampleRij, 14)
                        InvulRij = InvulRij + 1
                    End If
                    SampleRij = SampleRij + 1
                Loop
            End If
            InvulRij = InvulRij + 1
        Next Sh
Application.ScreenUpdating = True
End Sub
Deze code is gedeeltelijk gecopieerd van andere macro's, hij loopt niet vast maar doet ook weinig. Enkel wordt het bestand geopend.
Ik gok dat ik niet goed aangeef waar de cel staat die ingevuld moet worden.

mvg
Edwin
 
Gebruik geen On Error Resume Next als je niet weet welke fout je bewust wilt onderdrukken. Dus haal deze regel weg.
Loop vervolgens met <F8> eens door de code heen en kijk welke waarden de variabelen 'SampleRij' en 'InvulRij' krijgen.

ipv 13 regels code kan je het ook zo schrijven. (Cells is geen onderdeel van Workbook maar van Workbook.Sheets)
Code: 
wblog[COLOR="#FF0000"].sh.[/COLOR]Cells(InvulRij, 2).resize(,13) = Sh.Cells(SampleRij, 2).resize(,13).value
 
werkt nog niet

Hallo,

Ik heb gekeken wat er mis ging:
De regel
Code: 
[color=red]wblog[/color].Sh.Cells(InvulRij, 2).Resize(, 13) = Sh.Cells(SampleRij, 2).Resize(, 13).Value
Na stukjes te verwijderen bleek het rode niet te mogen.

Als ik dat weg haal, wordt er in ieder geval gecopieerd. Dit wel met 2 problemen; er wordt gecopieerd binnen het bron bestand, en dus niet van bron naar invulblad. (van wb naar wblog)
Het 2e probleem zit in het copiieren, bij het overstappen van sheet onthoud de macro waar hij gebleven was +2 (dus 1 witregel). De bedoeling is dat deze op de nieuwe sheet weer bovenaan begint.

mvg
Edwin
 
Plaats blend log.xlsm eens. Voor probleem 2
Loop vervolgens met <F8> eens door de code heen en kijk welke waarden de variabelen 'SampleRij' en 'InvulRij' krijgen.
Klik om te vergroten...
 
klein stukje verder

Hallo,

Het verstappen van invulrij tussen sheets verholpen, de aanduiding van invulrij stond te vroeg.
Nu enkel nog in het 2e bestand krijgen.

mvg
Edwin
 
Als ik er nog iets van begrijp mogelijk zo. Wat alle andere code in jouw bestand doet ??

Code: 
Sub VenA()
c00 = "D:\Temp\blend log gisteren.xlsx"
With GetObject(c00)
    For Each Sh In .Sheets(Array("Nieuwe blender", "Oude blender", "Hand blends en G-tanks"))
        With Sh.Range("B4:N28")
            .Copy ThisWorkbook.Sheets(Sh.Name).Cells(Rows.Count, 2).End(xlUp).Offset(1)
            .ClearContents
        End With
    Next Sh
End With
End Sub
 
Sub's

Hallo,

Ik weet dat de sub's van een niveau zijn wat om te huilen is, dus ik zal even aangeven wat welke doet.
Het lijkt er op dat je namelijk een andere aangepast hebt.

Van boven naar onder:

Sub datum vast
Deze maakt van de cellen welke de inhoud =vandaag() een harde datum, zodat deze niet mee loopt bij het copieren.

Sub log gisteren
Maakt een copie van de inhoud van het logboek, zodat ploegen 1 dag terug kunnen bekijken zonder in de database te hoeven.

Sub VenA
Je vorige assistentie, en inhoud van het dagrapprt wordt in de database gecopieerd.

Sub datum vandaag
Maakt Sub datum vast weer ongedaan, dit scheelt dus typewerk voor de opperators.

Sub datapresentatie
Ik weet even niet zeker of deze er al in stond, copieerd vanuit de database naar een bestand dat als bron van een presentatie draait.

Sub samplesgister
Pakt samples op die niet af zijn gemaakt, en plaatst deze bovenaan op de nieuwe dag. Hier zit het probleem.
Dit zit hier in:
Code: 
For Each Sh In Wb.Sheets
    If Sh.Name = "Nieuwe blender" Or Sh.Name = "Oude blender" Or Sh.Name = "Hand blends en G-tanks" Then
    SampleRij = 4
    InvulRij = 4
        Do Until Sh.Cells(SampleRij, 7) = ""
        If Sh.Cells(SampleRij, 9) <> "" And Sh.Cells(SampleRij, 11) = "" And Sh.Cells(SampleRij, 12) = "" And Sh.Cells(SampleRij, 13) = "" And Sh.Cells(SampleRij, 3) <> "premix" Then
            [color=red]Sh.Cells(InvulRij, 2).Resize(, 13) = Sh.Cells(SampleRij, 2).Resize(, 13).Value[/color]
            InvulRij = InvulRij + 1
        End If
        SampleRij = SampleRij + 1
                Loop
            End If
            InvulRij = InvulRij + 1
        Next Sh
Application.ScreenUpdating = True

Ik krijg niet voor elkaar dat in blend log gister gekeken wordt, en dan gecopieerd naar blend log



Verder is er nog de autosave module, deze werkt naar behoren.

mvg
Edwin
 
iemand?

Hallo,

Even een schopje omhoog; is er iemand die dit laatste stukje kan invullen?

Code: 
For Each Sh In Wb.Sheets
    If Sh.Name = "Nieuwe blender" Or Sh.Name = "Oude blender" Or Sh.Name = "Hand blends en G-tanks" Then
    SampleRij = 4
    InvulRij = 4
        Do Until Sh.Cells(SampleRij, 7) = ""
        If Sh.Cells(SampleRij, 9) <> "" And Sh.Cells(SampleRij, 11) = "" And Sh.Cells(SampleRij, 12) = "" And Sh.Cells(SampleRij, 13) = "" And Sh.Cells(SampleRij, 3) <> "premix" Then
            Sh.Cells(InvulRij, 2).Resize(, 13) = Sh.Cells(SampleRij, 2).Resize(, 13).Value
            InvulRij = InvulRij + 1
        End If
        SampleRij = SampleRij + 1
                Loop
            End If
            InvulRij = InvulRij + 1
        Next Sh

Hij doet het goed; hij kijkt naar de voorwaarde, en rijen die hier aan voldoen worden bovenaan gezet.
Het probleem is dat deze dit in het zelfde bestand doet, en dit zou naar een ander bestand moeten.
(er zit niets in wat naar een ander bestand verwijst omdat dit me niet lukt)
 
Hallo,

Weer even op brengen, hij blijft het zelfde probleem hebben.
Ik heb nog gekeken naar de destination te defineren, dit pakt hij echter niet op.

Weet iemand hoe dit gefixed kan worden?

alvast bedankt.
 
werkt

Hallo,

Bedankt voor de hulp, inmiddels werkt het:
Code: 
Sub Samplesgister()
Dim Wb As Workbook, Sh As Worksheet, wblog As Workbook, SampleRij As Integer, InvulRij As Integer
On Error Resume Next
Set Wb = Workbooks("blend log gisteren.xlsx")
If Wb Is Nothing Then Set Wb = Workbooks.Open("I:\OEE\testbestand\back-up\blend log gisteren.xlsx")
Set wblog = Workbooks("blend log.xlsm")
For Each Sh In Wb.Sheets
    If Sh.Name = "Nieuwe blender" Or Sh.Name = "Oude blender" Or Sh.Name = "Hand blends en G-tanks" Then
    InvulRij = 4
    SampleRij = 4
        Do Until Sh.Cells(SampleRij, 7) = ""
        If Sh.Cells(SampleRij, 11) = "" And Sh.Cells(SampleRij, 12) = "" And Sh.Cells(SampleRij, 13) = "" And Sh.Cells(SampleRij, 3) <> "premix" Then
        wblog.Worksheets(Sh.Name).Cells(InvulRij, 2).Resize(, 13).Value = Sh.Cells(SampleRij, 2).Resize(, 13).Value
            InvulRij = InvulRij + 1
        End If
        SampleRij = SampleRij + 1
                Loop
            End If
            InvulRij = InvulRij + 1
        Next Sh
Application.ScreenUpdating = True
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan