Looping per trovare le celle vuote quindi copia sopra

Ho trovato risultati simili, ma nulla che effettivamente risolve i miei problemi, quindi perdonami se l'inizio di questa domanda sembra familiare. Sto cercando di abbandonare una serie di righe per trovare la prima row vuota – questo bit che posso fare

Sub findblank() Dim xrow As Integer, xcol As Integer xrow = 1 xcol = 1 Do Until Cells(xrow, xcol).value = "" Cells(xrow, xcol).Select xrow = xrow + 1 Loop End Sub 

E 'il passo successivo che mi ha stompato, a less di utilizzare i timori danneggiati. Voglio select tutte le righe di dati sopra la cella vuota e copiarle. Li incrocerai in un nuovo foglio e ripeto questo process per un'altra area nel foglio originale.

Tornerò poi al foglio originale con l'ultima cella selezionata, resettare xrow / xcol e continuare verso il basso.

Essenzialmente prendo i pezzi di dati, where ci sono spazi vuoti inbetween, e la copia in un nuovo foglio, where voglio mettere solo una linea vuota tra i dati.

Grazie in anticipo.

Potresti fare qualcosa di simile (anche, cercare di evitare di contare su methods Select o Activate ).

Questo approccio definisce un object di gamma utilizzando la properties; End dell'object Range . Dal momento che lavorate con una gamma contigua, questa dovrebbe essere un'opzione per te. Quindi definire una variabile del foglio di lavoro per la destinazione del metodo Copy e voila:

 Sub findblank() Dim rng as Range Dim destSheet as Worksheet Dim xrow As Integer, xcol As Integer For xcol = 1 to 10 '// This will let you run this loop on multiple columns xrow = 1 '// Define your contiguous range using the End property: Set rng = Range(Cells(xrow, xcol), Cells(xrow, xcol).End(xlDown)) '// Define the destination for the copy/paste Set destSheet = Worksheets("Another worksheet") '// Modify as needed '// Copy & paste to another worksheet rng.Copy destSheet.Range(Cells(1, xCol)) End Sub 

Oppure, se si desidera utilizzare una struttura a loop (anche se non sembra necessario se è sufficiente utilizzare l'intervallo. .End metodo per il suggerimento precedente):

 Sub findblank() Dim rng as Range Dim destSheet as Worksheet Dim xrow As Integer, xcol As Integer xrow = 1 xcol = 1 '// Define the initial range Set rng = Range(Cells(xrow, xcol)) '// Define the destination for the copy/paste Set destSheet = Worksheets("Another worksheet") '// Modify as needed '// Loop until you find an empty cell Do Until Cells(xrow + 1, xcol).value = "" xrow = xrow + 1 Loop '// Once you exit the loop, just resize the rng object variable: Set rng = rng.Resize(xrow, 1) '// Copy & paste to another worksheet rng.Copy destSheet.Range("A1") End Sub