Controle celwaarde in range, afhankelijk van voorwaarde overkopieren naar ander Sheet

[KemalO]

Beste allen,

Ik heb geen ervaring met enige vba programmeer kunde of iets dergelijks. Ik zit helemaal vast met het volgende en hoop dat jullie mij kunnen helpen ;
In mijn workbook heb ik 2 tabbladen; Sheet1 en Sheet2
In sheet1 heb ik de volgende data:

Wanneer er sprake is van een getal in de range Q2:V2 beschouw ik dit als positief en kopieer de waarde naar sheet2 in cel S3 als zijnde positief.
Daarna wil ik dat mijn macro naar het volgende range Q3:V3 gaat en hetzelfde controle uitvoert, komt daar een getal voor, dan in sheet2 cel S4 de gekopieerde waarde als positief neerzetten.
Verdere voorwaarden zijn; 1)Wanneer in sheet1 zoals range Q7:V7 lege cellen zijn mag er niets gekopieerd worden en moet in sheet2 cel S8 geen waarde inkomen. 2) Wanneer in sheet1 zoals range Q9:V9 inhoud van cellen de waarde ND zijn mag er niets gekopieerd worden en moet in sheet2 cel S10 geen waarde inkomen. Na tegenkomen van beide voorwaarden springt de macro over naar volgende range totdat alle gevulde rijen in de kolommen Q:V gedaan zijn.
Zo ziet sheet2 er uit:


Ik heb tot nu twee sub procedures (voor de functionaliteiten selecteer ranges en bovengenoemde voorwaarden) kunnen maken, die niet helemaal volledig zijn. Uiteindelijk wil ik, als het kan, één subprocedure van maken.

Sub PosKopie()
Dim i As Integer
i = 2
    Sheets("Sheet2").Select
    Range("S3").Select
    ActiveCell.Range("A1").Select
    Sheets("Sheet1").Select
    Range("Q2:V2").Select
    
    Do While Sheets("Sheet1").Cells(i, 17).Value <> 0  'volgende stap: herkennen van integer achter ND
    If IsNumeric(ActiveCell) Then
    ActiveCell.Copy
    ActiveCell.Offset(1, 0).Select
    Sheets("Sheet2").Select
    ActiveCell.Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Value = "positive"
    ActiveCell.Offset(1, 0).Select
    Sheets("Sheet1").Select
    Else: ActiveCell.Offset(1, 0).Select
    Sheets("Sheet2").Select
    ActiveCell.Offset(1, 0).Select
    Sheets("Sheet1").Select
        End If
    i = i + 1
        Loop
End Sub

Sub LoopRange2() 'Bepaal van de geselecteerde range per cel numeric or not

    Dim rCell As Range
    Dim rRng As Range

    Set rRng = Sheet1.Range("Q2:V2")

    For Each rCol In rRng.Columns
        For Each rCell In rCol.Rows
            Debug.Print rCell.Address, rCell.Value
            If IsNumeric(rCell.Value) Then
                rCell.Activate
                Selection.Copy 'Dit stuk moet uitgebreid worden
            ElseIf isnotnumeric Then
                Exit For
            End If
          
          Next rCell
     
    Next rCol
End Sub

Enig hulp zou ik geweldig vinden want ik kom er niet meer uit.
Alvast bedankt,
KemalO

 

[OctaFish]

Aan plaatjes hebben we niet zoveel, en je verwacht hoop ik niet dat we hier zelf de gegevens gaan inkloppen . Die tijd wil ik wél steken in het kijken naar je vraag

 

[KemalO]

Paradigma en slecht gelezen

Beste Octavis, ik snap niet waarom je denkt dat ik verwacht de gegevens door iemand anders in te laten kloppen. Het is zelfs zonde van jouw tijd om dit soort dingen als bericht te plaatsen.
Als je niet wil helpen, reageer dan helemaal niet.

De plaatjes dienen ter verduidelijking.

Nogmaals, als je het goed gelezen had, kon je er van uit gaan dat ik niet veel ervaring heb in vba. Ik ben al trots dat ik iets heb kunnen maken tot nu toe. Helaas ben i vastgelopen, daarom zoek ik hulp/advies.

 

[Elsendoorn2134]

KemalO,

Ik snap niet waar je je druk om maakt we proberen je te helpen maar moeten daar wel de tools voor krijgen.
Hoe moeten we je helpen als wij niet een ons eigen voorstel kunnen uitproberen / testen?

Ik heb een poging gedaan maar dit is alleen mogelijk geweest door gegevens van jou over te nemen waar ik je hartelijk voor dank.

Sub PosKopie()

Dim rCell As Range
Dim nLoper1 As Integer      'Teller van sheet1
Dim nLoper2 As Integer      'Teller van sheet2
Dim nVeranderd As Boolean   'Stelt vast of deel van regel is gekopieerd.


With Sheets("Sheet1")        'Doorloop blad 1
For nLoper1 = 0 To .Range("Q2:" & .Range("Q9999").End(xlUp).Address).Rows.Count   'Tel aantal te doorlopen regels
    nVeranderd = False
    With .Range("Q2:V2").Offset(nLoper1, 0)                                     'Bekijk de verschillende regels
        For Each rCell In Sheets("Sheet1").Range("Q2:V2").Offset(nLoper1, 0)    'Bekijk iedere cel in de regel
            If IsNumeric(rCell.Value) And rCell.Value <> "" Then                'Test cel, als getal en niet leeg dan kopieren.
                rCell.Copy Destination:=Sheets("Sheets2").Range("S3").Offset(nLoper2, rCell.Column - 16)
                nVeranderd = True
            End If
        Next
    End With
    If nVeranderd Then                                                  'Bevat de regel getallen
        Sheets("Sheet2").Range("S3").Offset(nLoper2, 0) = "Positief"    'Plaats tekst voor de regel
        nLoper2 = nLoper2 + 1                                           'Ga naar de volgende regel op sheet2
    End If
Next
End With
End Sub

Ik denk trouwens niet dat de bovenstaande VBA-code bij je gaat werken. Als ik goed naar je schermafdrukken kijk
krijg ik het idee dat de getallen in je bestand teksten zijn. Dit is volgens mij te zien aan het feit dat ze punten
in plaats van komma's hebben en ze links in de cel staan. Tenzij je de opmaak hiervoor wijzigt staan alle getallen
rechts georiënteerd.
Dus probeer maar, maar garantie tot de deur.

Veel Succes.

 

[KemalO]

Elsendoorn2134, (en OctaFish)

Nu ik de vraag van OctaFish zo weer terug lees, denk ik dat mijn lichte opwinding waarschijnlijk niet nodig is geweest. Dat is het probleem met platte tekst, het is niet altijd mogelijk om de bedoeling van "medeschrijver" uit te lezen. Maar bedankt voor het attenderen daarop.

En, OctoFish, toch bedankt dat je de moeite wilde nemen om energie in te steken in het oplossen van mijn probleem. Bij deze mijn excuses, ik snapte waarschijnlijk niet wat jij nog meer wilde, anders dan wat ik had geupload. :thumb:

Elsendoorn2134, hartelijk dank voor je hulp en adviezen, ik heb kleine verandering in je code gemaakt maar ik ben onwijs op weg geholpen en mij rest nog code in te voeren om in Sheet2 1 regel over te slaan wanneer een rij in Sheet1 range Q2:V2 leeg is.

Wanneer ik er niet uitkom, zou ik jullie aub nog kunnen benaderen hierover?

mvg,
KemalO