VB Code to reorganize data

[rizmomin]

Hello:

Please refer to attached file.
I have data as shown from Column O onward.
Each days clockIn-Out data for each employee is as shown and occurs every 4th column until Column EE (31st)
I need VB Code to reorganize this data in Column A thru D as shown starting at Cell A3

Let me know if you have any questions.
Thanks.

Riz

[rizmomin]

Hello:

Can someone have a look at this.
Thanks

Riz

[Leith Ross]

Hello Riz,

The macro below has been added to the attached workbook. There is a button on the sheet to run it.

Sub ReOrganizeData()

    Dim Col     As Variant
    Dim Data    As Variant
    Dim DstRng  As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Row     As Long
    Dim SrcRng  As Range
    Dim SubRng  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        Set DstRng = Wks.Range("A3")
        
        Set RngBeg = Wks.Range("O2")
        Set RngEnd = Wks.Cells(3, Columns.Count).End(xlToLeft)
        
        Set SrcRng = Wks.Range(RngBeg, RngEnd)
        
            For Col = 1 To SrcRng.Columns.Count Step 4
                Set SubRng = SrcRng.Columns(Col).CurrentRegion
                ReDim Data(SubRng.Rows.Count, 3)
                
                For Row = 2 To SubRng.Rows.Count
                    Set Cell = SubRng.Cells(Row, 1)
                    Data(Row - 2, 0) = SrcRng.Cells(1, Col)
                    Data(Row - 2, 1) = Cell.Value
                    Data(Row - 2, 2) = Cell.Offset(0, 1).Value
                    Data(Row - 2, 3) = Cell.Offset(0, 2).Value
                Next Row
                
                DstRng.Resize(SubRng.Rows.Count - 1, 4).Value = Data
                Set DstRng = DstRng.Offset(SubRng.Rows.Count - 1, 0)
            Next Col
        
End Sub

[rizmomin]

Hi Leith:

This works great, thanks.
Now assume, i have date in Cell K1.
I need a separate code just to paste for this particular date with the same logic as you have done.

Just 1 day of data.
The reason is that i have lots of Monthly data which i can use the above code but going forward i can use new code for just 1 days data (Faster).
Please let me know if you have any questions.
Thanks.

Riz

[rizmomin]

Hi Leith:

I am having small issue with the code with my data.
Please see attached pic which shows where the data needs to start.
In my file, date will be at Row 599.
Start pasting at A600 down.

Please let me know if you have any questions.
Thanks.

Riz

[Leith Ross]

Hello Riz,

In your last post...

(1) Will the output still go to columns A:D?

(2) Will the Clock-In/Out data still start in column O?

(3) In in the first 3 rows, is there a cell pointing to the date you want to use?

[rizmomin]

Hello Leith or someone:

Please ignore #5 above, i have resolved.
I need help with #4.
Please let me know if you have any questions.
Thanks.

Riz

[Leith Ross]

Hello Riz,

If you have the date in K1 for a single day, will the output still be in columns A:D ?

[rizmomin]

Hi Leith:

Please ignore #5 above as i was able to modify code to take care with my data.
However, as i have mentioned in #4, i want to do the same for single date which will be in cell K1.
I have completed whole month, now going forward i would like to add the code so that it will paste at last row in column A.
Please let me know if you have any questions.
Thanks.

Riz

[rizmomin]

Hi Leith :

Yes, output will be in column A:D as usual.
Thanks
Riz

[Leith Ross]

hELLO rIZ,

Okay, this macro will check the contents of cell K1. If the cell does not contain a Date, it will exit silently. If the Date cannot be found, a message will be displayed.

Sub ReOrganizeByDay()

    Dim Col     As Variant
    Dim Data    As Variant
    Dim DstRng  As Range
    Dim DTRng   As Range
    Dim Row     As Long
    Dim SrcRng  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        Set DTRng = Wks.Range("K1")
        If IsEmpty(DTRng) Then Exit Sub
        
        Set SrcRng = Wks.Cells.Find(DTRng.Value, DTRng, xlFormulas, xlWhole, xlByRows, xlNext, False, False, False)
        If SrcRng.Address = DTRng.Address Then
            MsgBox "The Clock-In/Out date and time """ & DTRng.Text & """ was Not Found.", vbExclamation
            Exit Sub
        End If
        
        Set SrcRng = SrcRng.CurrentRegion
        
        Set DstRng = Wks.Range("A3")
                
            ReDim Data(SrcRng.Rows.Count, 3)
            
            For Col = 1 To 3
            
                For Row = 2 To SrcRng.Rows.Count
                    Set Cell = SrcRng.Cells(Row, 1)
                    Data(Row - 2, 0) = SrcRng.Cells(1, 1)
                    Data(Row - 2, 1) = Cell.Value
                    Data(Row - 2, 2) = Cell.Offset(0, 1).Value
                    Data(Row - 2, 3) = Cell.Offset(0, 2).Value
                Next Row
                
                DstRng.Resize(SrcRng.Rows.Count - 1, 4).Value = Data
            Next Col
        
End Sub

[rizmomin]

Hi Leith:

I was able to edit the code for my need.
Once again thanks a lot and will contact if further issue.
Thanks
Riz

[rizmomin]

Hi Leith:

Small problem.
It is overwriting at cell A3.
Basically once i start using then obviosly column A:D will have data until Today()-1.
Now Today() comes so new data needs to be pasted after the last data in column A.
I hope this is clear and please let me know if any questions.
Thanks
Riz

[Winon]

@Leith Ross,

Very impressive and effective code in Post #3!

I have added lines in Red, if that is O.K. with you?

Option Explicit
Sub ReOrganizeData()

    Dim Col     As Variant
    Dim Data    As Variant
    Dim DstRng  As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Cell As Range
    Dim Row     As Long
    Dim SrcRng  As Range
    Dim SubRng  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        Set DstRng = Wks.Range("A3")
        
        Set RngBeg = Wks.Range("O2")
        Set RngEnd = Wks.Cells(3, Columns.Count).End(xlToLeft)
        
        Set SrcRng = Wks.Range(RngBeg, RngEnd)
        
            For Col = 1 To SrcRng.Columns.Count Step 4
                Set SubRng = SrcRng.Columns(Col).CurrentRegion
                ReDim Data(SubRng.Rows.Count, 3)
                
                For Row = 2 To SubRng.Rows.Count
                    Set Cell = SubRng.Cells(Row, 1)
                    Data(Row - 2, 0) = SrcRng.Cells(1, Col)
                    Data(Row - 2, 1) = Cell.Value
                    Data(Row - 2, 2) = Cell.Offset(0, 1).Value
                    Data(Row - 2, 3) = Cell.Offset(0, 2).Value
                Next Row
                
                DstRng.Resize(SubRng.Rows.Count - 1, 4).Value = Data
                Set DstRng = DstRng.Offset(SubRng.Rows.Count - 1, 0)
            Next Col
            
       Wks.Columns.AutoFit
        
End Sub

Kind Regards.

[rizmomin]

Hello:

Thanks a lot for such a great help to Leith and Winon.

Very impressive work.
Riz

[Winon]

Hi rizmomin,

You are welcome, glad I could take the liberty of tweaking Leith's Code to assist you further.

Also thank you for adding to my Reputation.

@Leith Ross,

Thank you for not taking any offence, Leith.

You remain my mentor and the best!

Best Regards.

[rizmomin]

Hi Winon & Leith:

Would like 1 more feature on this code if possible.
Instead of pasting the data to the next blank row, would like to paste every 50 rows.
So basically for 1st of the month, start pasting as 600, 2nd of the month 650, 3rd of the month 700 and so on.
Please let me know if you have any questions.
Thanks.
Riz

[Leith Ross]

Hello Riz,

This macro calculates the next row in column "A" using the following equation: 600 + ((Day Number - 1) * 50). The day number is taken from the date in "K1".

Sub ReOrganizeByDay()

    Dim Cell    As Range
    Dim Col     As Variant
    Dim Data    As Variant
    Dim DstRng  As Range
    Dim DTRng   As Range
    Dim nextrow As Long
    Dim Row     As Long
    Dim SrcRng  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        Set DTRng = Wks.Range("K1")
        If IsEmpty(DTRng) Then Exit Sub
        
        Set SrcRng = Wks.Cells.Find(DTRng.Value, DTRng, xlFormulas, xlWhole, xlByRows, xlNext, False, False, False)
        If SrcRng.Address = DTRng.Address Then
            MsgBox "The Clock-In/Out date and time """ & DTRng.Text & """ was Not Found.", vbExclamation
            Exit Sub
        End If
        
        Set SrcRng = SrcRng.CurrentRegion
        
        nextrow = 600 + ((Day(DTRng) - 1) * 50)
        
        Set DstRng = Wks.Cells(nextrow, "A")
                
            ReDim Data(SrcRng.Rows.Count, 3)
            
            For Col = 1 To 3
            
                For Row = 2 To SrcRng.Rows.Count
                    Set Cell = SrcRng.Cells(Row, 1)
                    Data(Row - 2, 0) = SrcRng.Cells(1, 1)
                    Data(Row - 2, 1) = Cell.Value
                    Data(Row - 2, 2) = Cell.Offset(0, 1).Value
                    Data(Row - 2, 3) = Cell.Offset(0, 2).Value
                Next Row
                
                DstRng.Resize(SrcRng.Rows.Count - 1, 4).Value = Data
            Next Col
        
End Sub

[rizmomin]

Hi Leith:

Thanks a lot...i need to make sure the date in cell K1 is compared in Row 599 only and pick up the data from that location cloumn Row 600 down.
Please let me know if you have any questions.
Thanks.

Riz

[Leith Ross]

Hello Riz,

Sorry, I don't follow you. Can you provide an example of what you mean?

[rizmomin]

Hello Leith:

Please refer to attached file.
This is from my actual file.
I will have date in cell C1
Now go down to row 599.
This row will have date and data.
I will need the data in Column A:D from row 600 down.
Allocate 50 rows for each date.
Example :
Row 600 to 649 will be for 3/1/2016
Row 650 to 699 will be for 3/2/2016 and so on.
Row 700 to 749 will be for 3/3/2016 and so on.

Now depending on the date in cell C1, lookup the data ot match the date.
Lets say Date in C1 = 3/3/2016
In case paste the data from cell W600:Y649 and paste at B700 but add 3/3/2016 in column A (Cell A700 down until data for the day)

Please let me know if you have any questions.
Thanks.

Riz



Let me know if you have any questions.
Thanks.

[Leith Ross]

Hello Riz,

Thanks for the workbook. That made it clear. Here is the revised and tested macro.

Sub ReOrganizeByDay()

    Dim Cell    As Range
    Dim Col     As Variant
    Dim Data    As Variant
    Dim DstRng  As Range
    Dim DTRng   As Range
    Dim nextrow As Long
    Dim Row     As Long
    Dim SrcRng  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ThisWorkbook.Worksheets("Source")
        
        Set DTRng = Wks.Range("C1")
        If IsEmpty(DTRng) Then Exit Sub
        
        Set SrcRng = Wks.Cells.Find(DTRng.Value, Wks.Cells(599, 1), xlFormulas, xlWhole, xlByRows, xlNext, False, False, False)
        If SrcRng.Row <> 599 Then
            MsgBox "The Clock-In/Out date and time """ & DTRng.Text & """ was Not Found.", vbExclamation
            Exit Sub
        End If
        
        Set SrcRng = SrcRng.CurrentRegion
        
        nextrow = 600 + ((Day(DTRng) - 1) * 50)
        
        Set DstRng = Wks.Cells(nextrow, "A")
                
            ReDim Data(SrcRng.Rows.Count, 3)
            
            For Col = 1 To 3
            
                For Row = 2 To SrcRng.Rows.Count
                    Set Cell = SrcRng.Cells(Row, 1)
                    Data(Row - 2, 0) = SrcRng.Cells(1, 1)
                    Data(Row - 2, 1) = Cell.Value
                    Data(Row - 2, 2) = Cell.Offset(0, 1).Value
                    Data(Row - 2, 3) = Cell.Offset(0, 2).Value
                Next Row
                
                DstRng.Resize(SrcRng.Rows.Count - 1, 4).Value = Data
            Next Col
        
End Sub

[rizmomin]

Hi Leith:

You are Super excellllllllllllllllllller.
Thanks a lot for great help
Riz