VBA, Excel 2013, Knippen... en plakken in lege rij van andere tabel als dat kan

Status
Niet open voor verdere reacties.
jackfish

jackfish

Gebruiker
Lid geworden
10 sep 2010
Berichten
297
Beste VBA-experts,

1. Ik wil uit een tabel een rij knippen en plakken (in de eerstvolgende lege rij) van een andere tabel op hetzelfde tabblad.
2. Als er geen lege rij is in de andere tabel moet een msgbox de gebruiker hierop wijzen en verder niets doen.

Ik krijg het alleen punt 2 niet voor elkaar. Wie kan aangeven waar ik het anders moet aanpakken?

Code: 
Sub verplaats_naar_tabel_2()

    Range(ActiveCell.offset(0, 0), ActiveCell.offset(0, 12)).Cut

    Dim c As Range
    For Each c In Range("B5:B23")
    If c.Value = "" Then c.Select
    Next
    ActiveSheet.Paste
    Exit Sub
    
    For Each c In Range("B5:B23")
    If c.Value <> "" Then MsgBox "Sorry, er zijn geen lege rijen meer in deze tabel": Exit Sub
    Next
    
End Sub
 
Uit je code blijkt niet dat je een tabel gebruikt.
Plaats een bestand waar de tabellen in zitten.
 
Dit zijn inderdaad geen tabellen. Die staan wel in deze variant. Of ze bruikbaar zijn, is een ander verhaal, omdat ze mekaar wel eens in de weg konden zitten als je daarmee gaat rommelen.
 

Bijlagen

  • Tabellen.xlsx
    16,4 KB · Weergaven: 32
Dank voor de reacties HSV en Octafish. In welke richting zou ik beter kunnen zoeken om mijn wens te realiseren?

Code: 
Sub lege_cel_in_bereik()
    ActiveSheet.Range("A1:A10").Find("").Select
End Sub

maar dan nog zonder .select

Code: 
Range(ActiveCell.offset(0, 0), ActiveCell.offset(0, 12)).Cut ActiveSheet.Range("B28:B37").Find("")
 
Laatst bewerkt:
Bv.
Code: 
cells(application.max(28,cells(37,2).end(xlup).row,2).offset(1).resize(,13) = ..........
 
Een betere uitleg heeft de voorkeur. Je hebt 18 lege bedden in in Afdeling A? Vanuit Afdeling B of Afdeling C wil je gegevens verplaatsen naar Afdeling A en wel op de eerste plek die er vrij is?

Dmv een dubbelklik worden de gegevens verplaatst.

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Intersect(Target, Range(ListObjects(2).DataBodyRange, ListObjects(3).DataBodyRange)) Is Nothing Then Exit Sub
  Cancel = True
  ar = Cells(Target.Row, 2).Resize(, 12)
  With ListObjects(1)
    For j = 1 To .ListRows.Count
      If j < .ListRows.Count And .DataBodyRange.Cells(j, 2) = "" Then
        .DataBodyRange.Cells(j, 2).Resize(, 12) = ar
        Cells(Target.Row, 2).Resize(, 12).ClearContents
        Exit Sub
      End If
    Next j
    If j > .ListRows.Count Then MsgBox "Sorry, er zijn geen lege rijen meer in deze tabel"
  End With
End Sub
 

Bijlagen

  • Tabellen.xlsb
    20,4 KB · Weergaven: 39
Interessant experts, ik kom weer allerlei nieuwe dingen tegen, application.max & databodyrange.

Om het ingewikkeld te maken VenA. Vanuit elke afdeling zou gegevens verplaatst worden naar een andere afdeling.
Dus van A –> B en C, van B –> A, C en van C –> A, B
 
Ik heb zelf onderstaande code geschreven

Code: 
Sub leeg_bed_op_afdeling_B()
    If WorksheetFunction.CountA(Sheets("Blad1").Range("B28:B37")) < 10 Then
    Range(ActiveCell.offset(0, 0), ActiveCell.offset(0, 12)).Cut ActiveSheet.Range("B28:B37").Find("")
    Else
    MsgBox "Sorry, er zijn geen lege bedden meer op afdeling B"
    End If
End Sub
 
Als de afdeling "vol" ligt, krijg ik een foutmelding op de wijze waarop geknipt en geplakt wordt. Dit is niet het geval als je alleen werkt met een messagebox achter Then en Else. Ik begrijp het niet goed. Wie kan helpen?

Code: 
Sub leeg_bed_op_afdeling_B()
    If WorksheetFunction.CountA(Sheets("Blad1").Range("B28:B37")) < 10 Then
    Range(ActiveCell.offset(0, 0), ActiveCell.offset(0, 12)).Cut ActiveSheet.Range("B28:B37").Find("")
    Else
    MsgBox "Sorry, er zijn geen lege bedden meer op afdeling B"
    End If
End Sub
 
Het is maar in welke cirkel je wil blijven draaien. De code is zeer waarschijnlijk niet al te moeilijk staat al in #7 en is natuurlijk zeer eenvoudig aan te passen naar andere situaties. Ik zou er vooral niets mee doen en lekker door blijven rommelen met je eigen code.
Wat er moeilijk aan is om even een duidelijk uitleg te geven over wat de bedoeling is blijft ook een raadsel. Dus succes met het projectje.
 
Mijn excuses VenA, zeker niet mijn bedoeling geweest om voorbij te gaan aan uw inbreng.

Uitleg
Ik werk in een kleine kliniek met drie afdelingen. Patienten kunnen tijdens de opname (soms meerdere keren) overgeplaatst worden. Vooraf is niet duidelijk naar welke afdeling dat zal zijn. Dus vandaar de gewenste opties van A –> B en C, van B –> A, C en van C –> A, B.


Voordat ik het zelf kan aanpassen moet ik de code beter begrijpen. Ik heb hieronder achter de code geschreven wat ik denk dat er staat

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Hiermee wordt aangegeven dat er een actie verwacht wordt als men dubbelklikt in de worksheet.
  If Intersect(Target, Range(ListObjects(2).DataBodyRange, ListObjects(3).DataBodyRange)) Is Nothing Then Exit Sub 'Als er dubbelgeklikt wordt in tabel 2 en tabel 3, wordt daarbuiten geklikt, stop de procedure in deze module
  Cancel = True 'Kijk naar het volgende
  ar = Cells(Target.Row, 2).Resize(, 12) 'ar (vanwaar de keuze voor ar?)wordt gelijkgesteld met cellen   
  With ListObjects(1) 'voor tabel 1 geldt
    For j = 1 To .ListRows.Count 'ga vanaf rij 1 tot het einde van de rijen in de tabel na 
      If j < .ListRows.Count And .DataBodyRange.Cells(j, 2) = "" Then 'als het aantal ingevulde rijen kleiner is dan het aantal rijen in de tabel EN die rij leeg is dan
        .DataBodyRange.Cells(j, 2).Resize(, 12) = ar 'copieer de rij vanaf kolom 2 en breid de selectie 12 kolommen naar rechts uit
       Cells(Target.Row, 2).Resize(, 12).ClearContents 'wis de inhoud van de cel waarop geklikt is en doe dat 12 kolommen naar rechts
        Exit Sub 'stop de procedure in deze module
      End If 'einde van het als-statement
    Next j 'check de volgende rij
    If j > .ListRows.Count Then MsgBox "Sorry, er zijn geen lege rijen meer in deze tabel" 'als j groter is dan het aantal rijen in de tabel geef dan de msgbox weer
  End With 'einde
End Sub

Ik begrijp alleen niet goed waarom dan in tabel 1 regel 23 geen rij meer kan plakken.
 
Laatst bewerkt:
In tabel 1 staan geen 23 regels er wordt er niets geknipt en geplakt. Als je zelf in jouw comments de code al redelijk goed geanalyseerd hebt, wat let je dan om er zelf even wat mee te spelen? Van alles voorkauwen leer je niet veel en je blijft stelselmatig hangen in een summiere uitleg.

Nb. Vragen/tekst plaats je gewoon en code zet je tussen codetags.
 
Zet er een inputbox tussen.
 
Laatst bewerkt:
Wees blij dat er een bijlage stond.
Ik hoop voor je dat je het hebt gedownload, ik heb het verwijderd.

Ook nog rare opmerkingen plaatsen?
 
Welnu, de extensie van uw bestand was .xlsb en dat is niet te openen.
 
Beste HSV en VenA, nogmaals hartelijk dank voor de inhoudelijke en amusante reacties. Al met al een leerzaam draadje geweest.
`
@ HSV, het bestand bleek overigens wel degelijk te openen door het eerst op te slaan en daarna met Excel te openen. Direct openen vanuit Explorer lukte alleen niet.
Voor de geïnteresseerde bezoekers en leden het bestand van HSV: Bekijk bijlage afdelingen.xlsb

Met wat doorrommelen aan mijn projectje (zonder tabellen omdat anders mijn overige code niet meer werkte) toch tot een goed werkende oplossing gekomen.

Code: 
Sub tellen_afdeling_A()

     If WorksheetFunction.CountA(Sheets("Blad1").Range("B5:B23")) < 19 Then
        Range(ActiveCell.offset(0, 0), ActiveCell.offset(0, 12)).Cut ActiveSheet.Range("B5:B23").Find("")

    ElseIf WorksheetFunction.CountA(Sheets("Blad1").Range("B5:B23")) = 19 Then
        MsgBox "Sorry, er zijn geen lege bedden meer op afdeling A"
    End If
 
End Sub
 
Ik dacht dat je de naam van het bestand je niet aanstond, je bedoelde de extensie.
Er wordt door iedereen "Map1,Test,Testje" gebruikt vandaar dat ik de naam aanpas.

Je eigen oplossing:
En hoe verplaats je nu de gegevens naar C, of van C naar A of B?
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan