Waarden verplaatsen naar ander blad

[wlsandman]

Goedemiddag :thumb:

Ik heb de volgende code:

For Each r In ActiveSheet.Range("G20:G80")
If r.Value <> "" Then
    legeregel = Sheets("IGT").Range("E" & Rows.Count).End(xlUp).Offset(1).Row
    Sheets("IGT").Range("E" & legeregel) = r.Text
    End If
    Next

In range 'g20:g80' kijkt hij of er een waarde niet gelijk aan 0 in staat, wanneer dat zo is dan verplaatst hij die waarde naar de eerstvolgende lege regel op een ander blad.

Alleen als hij in range 'g20:g80' een waarden niet gelijk aan 0 vindt, dan moet hij die waarde kopieren en die waarde in de kolom ernaast, dus een waarde in range 'h20:h80'.

Weet iemand hier de code voor?

 

[Wigi]

Zo?

Dim r As Range
For Each r In Range("G20:G80")
    If r.Value <> "" Then r.Offset(,1).Text = r.Text
Next

Wigi

 

[wlsandman]

Bedankt voor je antwoord. Het klopt idd, maar hoe voeg ik jouw code in mijn code samen.

Zodat hij ook de waarde rechts van r.value kopieert naar het andere blad (IGT)!

 

[Wigi]

Gewoon erbij zetten?

Dim r As Range
For Each r In Range("G20:G80")
    If r.Value <> "" Then
        r.Offset(, 1).Text = r.Text
        legeregel = Sheets("IGT").Range("E" & Rows.Count).End(xlUp).Offset(1).Row
        Sheets("IGT").Range("E" & legeregel) = r.Offset(, 1).Text
    End If
Next

Wigi

 

[wlsandman]

Sorry, ik heb mijn vraag verkeerd gesteld.

Hij moet de waarde in range g20:g80 verplaatsen EN de waarde in de cel ernaast!

En hoe kan ik de formule zo aanpassen dat hij de waarde in de cel erboven neemt? Dus die offset-formule aanpassen.

 

[Wigi]

Doe maar een voorbeeldbestandje erbij en ook een duidelijkere uitleg.

 

[wlsandman]

ik heb het inmiddels zelfstandig opgelost maar ik ben het verder aan het uitwerken en nu wil ik de range in het voorbeeld ("G20:G80") laten verwijzen naar een gesloten excel document.

Sub test
Dim r As Range
Dim path As String

path = "'C:\Documents and Settings\wlsandman\Bureaublad\[testbestand.xls]sheet1'!$G$20:$G80"

For Each r In Workbooks("path2") ????
If r.Value <> "" Then

[...rest van de code....]
End sub

Hoe kan ik gegevens uit een range van een gesloten excel document halen en naar een open excel document verplaatsen?

Ik heb de volgende site's al gevonden, maar ik kom er niet uit.

http://www.ozgrid.com/VBA/ExtractFromClosedWorkbook.htm
http://www.erlandsendata.no/english/...bado&p=10&r=31
http://j-walk.com/ss/excel/tips/tip82.htm

 

[alberto10]

wlsandman,
Probeer onderstaande code eens :

Sub TestHaalWaarde()
  Dim pad As String, bestand As String, blad As String, cel As String
  pad = "C:\Documents and Settings\wlsandman\Bureaublad"
  bestand = "testbestand.xls"
  blad = "Sheet1"
  Application.ScreenUpdating = False
  For regel = 20 To 80  'rij 20 t/m 80
    For kolom = 7 To 8  'kolom G t/m H
      cel = Cells(regel, kolom).Address
      Cells(regel, kolom) = GetValue(pad, bestand, blad, cel)
    Next kolom
  Next regel
  Application.ScreenUpdating = True
End Sub

Functie

Private Function GetValue(path, file, sheet, ref)
  ' Haal een waarde uit een gesloten werkboek
  Dim arg As String
  ' Kontroleer of de file bestaat
  If Right(path, 1) <> "\" Then path = path & "\"
  If Dir(path & file) = "" Then
    GetValue = "File Niet Gevonden!"
    Exit Function
  End If
  ' Creeer het argument
  arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(ref).Range("A1").Address(, , xlR1C1)
  ' Voer de eigenlijke XLM macro uit
  GetValue = ExecuteExcel4Macro(arg)
End Function

 

[wlsandman]

Alberto, bedankt voor je antwoord maar ik heb het inmiddels iets eenvoudiger opgelost.

    sWb = Application.GetOpenFilename
     ' open the source workbook, read only
    Set wb = Workbooks.Open(sWb, True, True)
    With ThisWorkbook.Worksheets(1)
         ' read data from the source workbook
    
    For Each r In ActiveWorkbook.Sheets(1).Range("G20:G90")

    If r.Value <> "" And r.Offset(, -3).Value <> "" Then
    legeregel = Workbooks(bn).Sheets(bns1).Range("Q" & Rows.Count).End(xlUp).Offset(1).Row
    Workbooks(bn).Sheets(bns1).Range("Q" & legeregel) = r.Text  'de waarde cc kopieren naar kolom Q
    
    r.Value = FormulaR1C1 = "=CEILING(RC[-3],1)"

Hier kan ik nu gewoon zelf een bestand openen, waarna de macro de gegevens overzet naar een ander document.

Alleen nu wil ik ook een waarde overzetten, bv 21,3. Alleen deze waarde moet afgerond worden (afronden naar boven op een veelvoud van 1). Hoe kan ik dat gelijktijdig doen met het overzetten (dus niet op een omslachtige manier). In bovenstaande code heb ik al het een en ander geprobeerd, of hij geeft een foutmelding, of hij geeft de waarde ONWAAR

Weten jullie een oplossing?

 

[Wigi]

Verander eens

Workbooks(bn).Sheets(bns1).Range("Q" & legeregel) = r.Text  'de waarde cc kopieren naar kolom Q
    
    r.Value = FormulaR1C1 = "=CEILING(RC[-3],1)"

in

Workbooks(bn).Sheets(bns1).Range("Q" & legeregel) = Round(r.Value,0)  'de waarde cc kopieren naar kolom Q

Werkt dit?

Wigi

 

[wlsandman]

Het werkt perfect :thumb:

Ware het niet dat hij een waarde van 0,3 afrond naar 0. Maar het moet altijd naar boven afgerond worden. Dus 0,3 moet 1 worden, en 54,45 moet 55 worden!

 

[Wigi]

Workbooks(bn).Sheets(bns1).Range("Q" & legeregel) = WorksheetFunction.Ceiling(Round(r.Value), 1)

 

[wlsandman]

mmm, vreemd

0,3 rond hij nog steeds af op 0, en 1,1 op 1.

 

[Wigi]

Heel vreemd

Ceiling functie

 

[Wigi]

Zet voor die regel code ook eens:

Debug.Print Round(r.Value)

Voer de code uit.

Druk Ctrl-G in VBA en kopieer de inhoud van dat schermpje naar hier.

Wigi

 

[wlsandman]

[auto_open] <
[SetupFunctionIDs] <
[SetupFunctionIDs] >
[PickPlatform] <
[PickPlatform] >
[VerifyOpen] <
[VerifyOpen] > 1
[RegisterFunctionIDs] <
[RegisterFunctionIDs] >
[auto_open] >
 22 
 0 
 22 
 0 
 1 
 0 
 1 
 1 
 3 
 1 
 1 
 2 
 1 
 1 
 2 
 3 
 1 
 1 
 1 
 22 
 1 
 1 
 1

Dit???

 

[Wigi]

Dit bedoel ik ja, maar je moet de regel met Debug.Print wel zetten vóór de regel met de ceiling functie.

 

[Wigi]

Sorry, ik zie mijn fout

Workbooks(bn).Sheets(bns1).Range("Q" & legeregel) = WorksheetFunction.Ceiling(r.Value, 1)

De Round was er nog blijven instaan...

 

[wlsandman]

Perfect :thumb:

 

[wlsandman]

edit done