Loop help?

[option]

Hey guys,

I'm trying to set up a loop to do through a range of cells and copy them to another sheet in my workbook. I need this loop to stop after 2 consecutive blank cells, that way it doesn't go through all 65536 rows of excel. here's what I've got so far. It goes cell by cell, but theres got to be an easier way to do this. Any help would be greatly appreciated! Thanks!!

Public Sub SaveRE()
On Error GoTo prcdErr
 Dim strPathSeg As String, strFileSeg As String
   Dim r1 As Double, c As Double, i As Double
    Dim r2 As Double
      

    r2 = 2
    r1 = 10





For c = 10 To 65536
        Sheets("DataEntry").Select
        If Range("D" & r1) <> "" Then
        Range("D" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("A" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Sheets("DataEntry").Select
        If Range("E" & r1) <> "" Then
        Range("E" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("B" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Sheets("DataEntry").Select
        If Range("F" & r1) <> "" Then
        Range("F" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("C" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Sheets("DataEntry").Select
        If Range("G" & r1) <> "" Then
        Range("G" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("D" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Sheets("DataEntry").Select
        If Range("H" & r1) <> "" Then
        Range("H" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("E" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Sheets("DataEntry").Select
        If Range("I" & r1) <> "" Then
        Range("I" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("F" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Sheets("DataEntry").Select
        If Range("J" & r1) <> "" Then
        Range("J" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("G" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Sheets("DataEntry").Select
        If Range("K" & r1) <> "" Then
        Range("K" & r1).Select
        Selection.Copy
        Sheets("Output").Select
        Range("H" & r2).Select
        ActiveSheet.Paste
        Else
        i = i + 1
        Rows("2:2").Select
        Application.CutCopyMode = False
        Selection.Insert Shift:=xlDown
        r1 = r1 + 1
         i = i + 1 'Null Column Counter
        If i > 2 Then 'More than 2 Null columns
        Exit For 'No more data to import in this row.
        End If
        End If
        End If
        End If
        End If
        End If
        End If
        End If
        End If
    Next c

prcdExit:
    Exit Sub
prcdErr:
    Call FatalError(Err.Number, Err.Description, "modListBuilder", "BuildProcessList", False)
    Resume prcdExit
End Sub

 

[option]

Ok, I got it down to this :

    Dim SiteCol As Range, Row As Object
     
    Set SiteCol = shtDE.Range("D10:K65536") 'Range containing data
     
    For Each Row In SiteCol
        If IsEmpty(Row) Then
            Exit Sub
        End If
        
            Sheets("DataEntry").Select 'select RE sheet
        If Row.Value <> "" Then
            Row.Select 'select row containing RE data
            Row.EntireRow.Copy
            Sheets("Output").Select 'switch to output sheet
            Range("A" & r2).Select
            ActiveSheet.Paste 'paste entire row
            Range("A2:C2").Select
            Application.CutCopyMode = False
            Selection.Delete Shift:=xlToLeft 'remove excess data
            Rows("2:2").Select
            Application.CutCopyMode = False
            Selection.Insert Shift:=xlDown 'insert new blank in output sheet
             
        End If
             Next Row

Now it just keeps copying the same row over and over and not advancing. Any ideas?

 

[Brianwarnock]

Dim Row As Integer
    
 With Worksheets("dataentry").UsedRange
    lastrow = .Cells(1, 1).Row + .Rows.Count - 1
 End With
       Row = 10
        Do While Row <= lastrow
            Worksheets("DataEntry").Select 'select RE sheet
        
            Rows(Row).EntireRow.Copy
            Worksheets("Output").Select 'switch to output sheet
            
            Rows(2).Insert   ' If you don't want to reverse the order then index this as per row on dataentry
            Row = Row + 1
        Loop

The above will copy the rows for you reversing the order which seemed to be what you wanted !

The delete in your code promptly deleted the copied data so I removed that , not sure what you were attempting.

Brian

 

[option]

Thats doing the same thing the second code I posted does. What is happening is that I am copying all of the row (ex: A1:G11) and I need to start my copy @ cell 10. So the delete in my code was removing cells 1-9, and shifting the data to its appropriate cells. I guess the easiest was to put it, I need a loop that does this:
Select range Dx to Kx (x being the row) from worksheet dataentry
copy selection
goto worksheet output
paste selection
shift data down/insert new row above
repeat until 2 consecutive null values are found on sheet dataentry

I'm still trying to work this out, but I just keep coming back in circles! (quite ironic, eh?)

 

[Brianwarnock]

How can you start at D10 if you are not copying A1:G11

Brian

 

[Brianwarnock]

Didn't my code copy from row 10 to last row, I thought yours only copied 1 row, tho' I couldn't get it to work at all.

Brian

 

[option]

I put your code into my workbook and it copied from A10 to K10, which is what my code did as well. I don't see why I couldn't start at D10 and only copy between D10:K65536. If I can get the actual loop in my code to work, then I'd be set. I don't know why, but my code only copied the one row multiple times then gave out. This is quite frustrating hahaha. I don't know, Maybe I should rethink my strategy here...

 

[option]

Ok, this isn't EXACTLY what I wanted, but if I use the following, it copies the data I need (along with all of the extra blank cells)

Public Sub SaveRE()
On Error GoTo prcdErr
Dim SiteCol As Range, Row As Object

Set SiteCol = shtDE.Range("D10:K65536") 'Range containing data


SiteCol.Cells.Copy
Sheets("Output").Select
ActiveSheet.Paste

prcdExit:
Exit Sub
prcdErr:
Call FatalError(Err.Number, Err.Description, "modListBuilder", "BuildProcessList", False)
Resume prcdExit
End Sub

 

[Brianwarnock]

Why don't you use lastrow in setting your range as I illustrated?
Your latest code will not reverse the order which your first code would have done and which coded for. I did question this.
With my code you code easily add clearing the columns a b c.
However as you don't want the data reversed but just want it as is in the same cells then

With Worksheets("dataentry").UsedRange
    lastrow = .Cells(1, 1).Row + .Rows.Count - 1
 End With
Set myrange = Range(Cells(10, 4), Cells(lastrow, 11))

myrange.Cells.Copy
Worksheets("Output").Select
ActiveSheet.Paste

will do that, I leave you to add error checking.

BTW What is shtDE ?

Brian

 

[option]

Ok, this was so much easier than I made it out to be. Here is my 100% working solution:

Option Explicit

Public Sub SaveREs()
On Error GoTo prcdErr
Dim proc As Double, ct As Double, r As Double, q As Double

q = 2
r = 10
For ct = 1 To 65536
        If shtDE.Range("D" & r) <> "" Then
            shtOP.Range("A" & q) = shtDE.txtEmpID
            shtOP.Range("B" & q) = shtDE.txtREDate
            shtOP.Range("C" & q) = shtDE.Range("F" & r)
            shtOP.Range("D" & q) = shtDE.Range("G" & r)
            shtOP.Range("E" & q) = shtDE.Range("J" & r)
            shtOP.Range("F" & q) = shtDE.Range("D" & r)
            shtOP.Range("G" & q) = shtDE.Range("K" & r)
            r = r + 1
            q = q + 1
           Else
            GoTo prcdExit
           End If
    Next ct
    
    
prcdExit:
    Exit Sub
prcdErr:
    Call FatalError(Err.Number, Err.Description, "modListBuilder", "BuildProcessList", False)
    Resume prcdExit
End Sub

Thanks a lot for everything!

 

[Brianwarnock]

The copy of the named ranges is constant as for the rest just modify my previous code with

myrange.Cells.Copy
Worksheets("Output").Select
Range("C2").Select
ActiveSheet.Paste

I do not look for 2 blanks but look for the last used cell in your range.
Is there a reason why this cannot work, is there data below the last row in the range of cols d to k in other cols that is.

Brian

 

[Brianwarnock]

Notice that you got it working before I posted, I take it you modified the earlier post explaining shtDE?

Cheers Brian

 

[option]

The only reason I'm selecting D10:Kwhatever is because everything surrounding those cells is cosmetic to the GUI of the workbook. I'm using this for employees to keep track of their daily work. By taking the info from said cells and putting it into the output sheet, we can then save the output sheet and import it into our access database that deals with payroll, since it would then be in the proper format.

 

[Brianwarnock]

That's vba code running as an EXCEL macro, it will be topped and tailed by something like


Sub copycells()


End Sub


Brian

 

[chergh]

It's just spam Brian, they're posting vaguely ontopic spam so they can get away with putting the link in their signature.

 

[Brianwarnock]

Thanks chergh guess I'm missing things as I get older, but then I didn't read the signature either.
Kinda makes my post look silly now that the post it is referring to has been deleted, but if I deleted mine it would leave yours as an orphan post, and reduce my post count, can't have that

Brian