Copy associated cells for not blank cells.

homegrownandy · Apr 5th 2016

I have a spreadsheet with date values in row 1 and in column A i have a list of jobs. We have thousands of entrys on this spreadsheet, which shows work we carried out and when.

In every cell with a value (not blank) I would like for that to be pasted on a new sheet, with the accociated date (row one) and associated job name (column A) to be pasted in the cells next to it.

It would take me weeks to go through all of this data manually, with each one checking dates and names. So if i have this in a table with the name/date/note all in a list format I can upload them to the database.

The dates are all now text values, so copying them isnt an issue.

Hope someone can help me put together some code.

forum.ozgrid.com/index.php?attachment/68775/
Edit: This is some sample data just showing what exists and what I want. I would like the new data to be on a new sheet, and in this example the data is far less than whats on the actual data.

thanks

skywriter · Apr 5th 2016

Re: Copy associated cells for not blank cells.

It would be better if you uploaded an example file with a before and after tab so we can see what you want.

When you click reply there will be a new button labeled go advanced, click on that button then there will be a paperclip icon in the toolbar, click on that icon and follow the instructions.

homegrownandy · Apr 6th 2016

Re: Copy associated cells for not blank cells.

Ive done as sugested, Just hope someone can help me do this as doing this manually would take so long.

Cheers..

Grimes0332 · Apr 6th 2016

Re: Copy associated cells for not blank cells.

It's not overly refined, but should work.

Code

Sub x()




   Dim r As Excel.Range
   Dim c As Excel.Range
   Dim ws As Excel.Worksheet
   Dim UseRow As Long
   
   Application.ScreenUpdating = False
   
   ' Assuming data starts in A1 - as you have other info on the posted sheet,
   ' cannot use UsedRange
   ' Get the contiguous cells starting in A1. This will refer to all cells bounded by a completely
   ' empty row and column
   Set r = Sheet1.Range("A1").CurrentRegion
   ' Resize to ignore Column A and Row 1
   Set r = r.Offset(1, 1).Resize(r.Rows.Count - 1, r.Columns.Count - 1)


   ' Add a worksheet for the results
   Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
   With ws.Range("A1").Resize(, 3)
      .Value = Array("Name", "Test", "Date")
      .Font.Bold = True
   End With
   
   For Each c In r
         
      If c.Value <> vbNullString Then
         
         UseRow = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
         ws.Cells(UseRow, 1).Value = Sheet1.Cells(c.Row, 1).Value
         ws.Cells(UseRow, 2).Value = c.Value
         ws.Cells(UseRow, 3).Value = Sheet1.Cells(1, c.Column).Value
      End If
   Next
            
   Application.ScreenUpdating = True
   
End Sub

Display More

It could possibly be refined further by trying the following change

Code

' From
   For Each c In r
'To
   For each c in r.SpecialCells(xlCellTypeConstants)

But
1. Excel used to have a problem if more than about 8,000 cells were selected, you can try testing it with your data
2. You don't say if the actual cell contents are text or the results of a formula - if so then use xlCellTypeformulas (or something like that, Intellisense will show the correct term)

homegrownandy · Apr 6th 2016

Re: Copy associated cells for not blank cells.

Runtime Error 1004

I think you were right earlier when you said there was too much data. Is it possible to make this loop or something? I appreciate what you have done though, you've freed up days of time for me.. even if i spend a day or two trying to make this run in a loop.

Thanks.

Grimes0332 · Apr 6th 2016

Re: Copy associated cells for not blank cells.

Don't understand what you mean - it does run a loop.

It also should work for the basic loop as posted (ignoring the 'refinement') but can't really say anything as you haven't said where the error is raised.

Grimes0332 · Apr 6th 2016

Re: Copy associated cells for not blank cells.

Just to add - it does work for the basic code posted.

I extended your grid to cover 900 columns and 106,000 rows and ran the procedure with no problems but it did take a little time and I got bored after it had copied 500,000 rows to the new sheet.

Trying to use SpecialCells, though, caused Excel pause for quite some time while it figured out which cells qualified (XL2013, not tested with earlier versions). That's not a problem, just don't use SpecialCells.

I you still have issues then please explain exactly what is happening, or not, and where.

homegrownandy · Apr 7th 2016

Re: Copy associated cells for not blank cells.

I couldnt actually get to the error at the time, It was locking up my computer totally. I had some other code in that document which i think was stopping it. I've copied the data to a new document and run the code and it worked perfectly. Thanks a lot for that. Really appreciate it.

Grimes0332 · Apr 7th 2016

Re: Copy associated cells for not blank cells.

If other code is firing and possibly interfering with the procedure then you can disable that using

Code

Application.EnableEvents = False

at the start of the procedure, not forgetting to re-enable events when it finishes. This should really then have error handling included as turning off event handling will leave Excel totally unresponsive if it should encounter an error. For example:

Code

Sub x() 
     
    Dim r As Excel.Range 
    Dim c As Excel.Range 
    Dim ws As Excel.Worksheet 
    Dim UseRow As Long 
     
    On Error Goto ErrHandler


    With Application
        .ScreenUpdating = False 
        .EnbleEvents = False
    End with
     
     ' Assuming data starts in A1 - as you have other info on the posted sheet,
     ' cannot use UsedRange
     ' Get the contiguous cells starting in A1. This will refer to all cells bounded by a completely
     ' empty row and column
    Set r = Sheet1.Range("A1").CurrentRegion 
     ' Resize to ignore Column A and Row 1
    Set r = r.Offset(1, 1).Resize(r.Rows.Count - 1, r.Columns.Count - 1) 
     
     ' Add a worksheet for the results
    Set ws = Worksheets.Add(after:=Sheets(Sheets.Count)) 
    With ws.Range("A1").Resize(, 3) 
        .Value = Array("Name", "Test", "Date") 
        .Font.Bold = True 
    End With 
     
    For Each c In r 
         
        If c.Value <> vbNullString Then 
             
            UseRow = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row 
            ws.Cells(UseRow, 1).Value = Sheet1.Cells(c.Row, 1).Value 
            ws.Cells(UseRow, 2).Value = c.Value 
            ws.Cells(UseRow, 3).Value = Sheet1.Cells(1, c.Column).Value 
        End If 
    Next 
     
ErrHandler:
    
    If Err.Number <> 0 then
        MsgBox "Error: " & Err.Description, vbExclamation, "Error"
    End if


    With Application
       .ScreenUpdating = True 
       .EnableEvents = True
    End With
     
End Sub

Display More

Copy associated cells for not blank cells.

Participate now!

Share