Previous Topic Next Topic

Unique records

Solved/Closed
Kamal - Oct 28, 2011 at 01:17 PM
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 - Dec 12, 2013 at 10:29 AM
Hello,

I am very new to excel macros, however, I want to make a macro that will provide unique records from three different excel sheets.

I have employees listed in three different excel files. What I want is that when I copy three different excel sheet, the fourth sheet will provide me the unique records. I'm not sure if the employee IDs can also be recognized from sheets they belong to.

Please let me know if you have any questions. I would really appreciate if someone can help me out in making this macro.

Thanks & Regards
Kamal Hassan

29 responses

Answer 1 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Feb 27, 2012 at 10:11 AM
Hi Kamal,

No worries about the delay, please take as much time as needed to get satisfied.

It's never my intention to present a faulty or error-filled code. If it does happen it's mainly because I'm not properly educated (self-taught). So we are on the same page for achieving an error-free macro.
Please test the code in any thinkable way and if you find something I will do my best to find a solution.

1. You are right about this. Added a codeline which skips the sheet if the ID column doesn't contain any ID's

2. I'm not getting anything weird by applying headers, maybe it's solved because of the change due to point 1.

3. Same as point 1.

Here is the code: 
Sub Test()
Dim ws As Worksheet
Dim lRow, lRow2, lRow3 As Integer
Dim cCol As Integer
Dim x, y As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "UNIQUE RECORDS" Then GoTo Nxt
cCol = 5
    If ws.Name = "INTERMITTEN_FMLA_RETURN_TO_WORK" Then cCol = 1
lRow = ws.Cells(Rows.Count, cCol).End(xlUp).Row
    If lRow = 1 Then GoTo Nxt
Sheets(ws.Name).Select
        For Each cell In Range(Cells(2, cCol), Cells(lRow, cCol))
cell.Copy Destination:=Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("UNIQUE RECORDS").Select
Range("A" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
        Next cell
Nxt:
Next ws

Sheets("UNIQUE RECORDS").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

x = Range("A" & Rows.Count).End(xlUp).Row
y = 2

    Do
        If Cells(x, 1).Value = Cells(x - 1, 1) Then Cells(x, 1).EntireRow.ClearContents
        x = x - 1
    Loop Until x = y

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

    If Sheets("UNIQUE RECORDS").AutoFilterMode Then
        ison = "On"
    Else
        ison = "Off"
    End If
    If ison = "Off" Then Range("A1:B1").AutoFilter

lRow3 = Range("A" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="NOLOAD"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 100)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="RTW_RECORDS"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="GOOD"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="NOACTION"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="INTERMITTEN_FMLA_RETURN_TO_WORK"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="MULT_RTW"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

Selection.AutoFilter Field:=2

lRow2 = Range("C1").End(xlDown).Row
lRow3 = Range("C" & Rows.Count).End(xlUp).Row

Range(Cells(lRow2, "C"), Cells(lRow3, "D")).Cut Destination:=Range("A2")

lRow2 = Range("A" & Rows.Count).End(xlUp).Row

Range("A2:B" & lRow2).Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

Application.ScreenUpdating = True
End Sub

Kind regards,
Trowa
1
Answer 2 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Nov 28, 2013 at 11:00 AM
Hi Kamal,

I'm doing great indeed, thanks for asking.

Well your query could be solved using a macro, but let me show you a different way which may benefit you in other situations.

We need 3 temporary columns. I used B, C and D but feel free to use any empty columns on your sheet.

Row 1 is header.

B2: P
B3: D
B4: P
B5: D

C2: 0.5
C3: 1
Select C2 and C3 and drag the selection down to match column B (so 2 cells down).

D2: =ROUND(C2,0)
Select D2 and drag it down to match column B (so 3 cells down).

A2: =B2&D2
Select A2 and drag it down to match column B (so 3 cells down).

Now select A2:D5 and drag the selection down as far as desired.

Copy column A --> right-click on A1 and select Paste special --> values only --> OK.

Now you can remove the values from columns B, C and D.

Best regards,
Trowa

Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.
1
Answer 3 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Oct 31, 2011 at 10:49 AM
Hi Kamal,

You are talking about 3 sheets and 3 files.
Does each file contain 3 sheets?
Do you have 3 sheets or 3 files?

What makes a record unique?

Could you answer the last question and upload your file(s) to a filesharing site like www.speedyshare.com so the first two question will be answered. And for us to write a more specific macro for you.

Best regards,
Trowa
0
Kamal
Nov 1, 2011 at 11:52 AM
Thanks Trowa for your response.

I'm talking about just three different worksheets named NOLOAD, RTW_RECORDS and GOOD. In all these worksheets, employee IDs are mentioned. So I want a macro that will look into the Column E of these worksheets and take out the unique employee IDs.

Further, when macro will pull out the unique employee IDs, I also want to know which employee ID is from which worksheet.

I'll be sharing all three files with you very soon as I'm not able to upload the files from my office PC. I can send you the files if you can provide me any email address to me.

Looking forward to your kind support in this help.

Thanks & Regeds
Kamal
0
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Nov 3, 2011 at 10:55 AM
Hi Kamal,

See if this yields the desired result:

1. Create a sheet anywhere in your workbook (excel file) called "Unique Records".
You can change the name to whatever you like as long as you do a find & replace (CTRL + H) on the code.
2. optional. Create headers in the new sheet
A1: Employee ID
B1: From sheet
3. Use this code: 
Sub test()
Dim ws As Worksheet
Dim lRow As Integer
Dim lRow2 As Integer

For Each ws In Worksheets
If ws.Name = "Unique Records" Then GoTo Nxt
lRow = ws.Range("E" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("E1:E" & lRow)
cell.Copy Destination:=Sheets("Unique Records").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("Unique Records").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Next cell
Nxt:
Next ws

Sheets("Unique Records").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

lRow2 = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A2:A" & lRow2)
If cell.Value = cell.Offset(1, 0).Value Then cell.EntireRow.ClearContents
Next

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

End Sub

Feel free to comment so we can tweak the code.

Best regards,
Trowa
0
mari
Nov 22, 2011 at 05:30 PM
oye muchas gracias por tu ayuda habia buscadoen internet sobre lamp , pero no entendia muchoo gracias wwey ahora si montare mi pagina ;)
0
Answer 4 / 29
Kamal
Nov 15, 2011 at 10:29 AM
Hello Trowa

Really sorry for not getting back to you earlier. I was out of city for few days.

Trowa, first of all, I would like to thank u for taking out time for making the code for me. I want to tell you that it worked really well for me.

Just want to request you to make the following modifications in the code, if possible:

1. I have made four worksheets named NOLOAD, RTW_RECORDS, GOOD and UNIQUE RECORDS. I want to put a condition in the code that if an employee is coming under NOLOAD sheet and RTW_RECORDS sheet, it will show NOLOAD in front of that employees. Same will go with GOOD file. However, in case of RTW_RECORDS sheet and GOOD sheet, it will show RTW_RECORDS in front of that employees. NOLOAD has the highest priority and GOOD file has the lowest.

2. I have also made two headers in UNIQUE RECORDS sheet i.e. Parter_IDs and LOA Report. I put the cursor on cell A2 and run the code. However, it shows last record as "EE_ID GOOD" instead of a employee ID and sheet name. So please correct this issue.

3. I have made a macro named TEST macro and copied the coding into that macro. I have also assigned a shortcut key i.e. CRTL + W to that macro. Is this a correct way or will it impact the coding anyway?

4. I have formatted the headers by applying font as TAHOMA Bold 10 and the below text as TAHOMA Bold 9. Also, I have selected the 'ALL BORDER' option for the data pulled after running the code. However, whenever I'm running the code, it's pulling-up the data as simple text. Can you please do something about it?

I know I'm asking a lot from you but believe me, it will really help a lot of people in my organization.

Thanks & Regards
Kamal
0

Didn't find the answer you are looking for?

Ask a question
Answer 5 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Nov 17, 2011 at 10:34 AM
Hi Kamal,

Let me give you an update on where I am right now.

1. I understand what you want to do, just need more time to find a way to do this.

2. Fixed
Changed this line: 
For Each cell In ws.Range("E1:E" & lRow)
into this: 
For Each cell In ws.Range("E2:E" & lRow)

3. That is a correct way to acces your macro in a faster way. Another way would be to create a button.

4. The code copies cells with it's format intact. Only the sheets name isn't copied, therefore I implemented a part where the sheets names will be formatted in TAHOMA Bold 9 with Borders.

Please check the current adjustments and see if they do what they should.
Here is the adjusted code: 
Sub test()
Dim ws As Worksheet
Dim lRow As Integer
Dim lRow2 As Integer

For Each ws In Worksheets
If ws.Name = "UNIQUE RECORDS" Then GoTo Nxt
lRow = ws.Range("E" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("E2:E" & lRow)
cell.Copy Destination:=Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Next cell
Nxt:
Next ws

Sheets("UNIQUE RECORDS").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

lRow2 = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A2:A" & lRow2)
If cell.Value = cell.Offset(1, 0).Value Then cell.EntireRow.ClearContents
Next

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

End Sub


Best regards,
Trowa
0
Kamal
Nov 17, 2011 at 11:06 AM
Thanks Trowa for the modifications made to the code. I have tested the code and found the following:

1. The most important thing of this code is still missing unfortunately i.e. the code is providing the unique records, however, just showing which record is belong to which sheet. I want the records from NOLOAD sheet will override the records from RTW_RECORDS or GOOD sheet.

2. If there's no record in GOOD sheet, the last record is showing 'EE_ID' and in Partner_IDs header and 'GOOD' in LOA Report header of Unique Records worksheet, which is not required.

3. Sheets' name is coming in desired format i.e. Tahoma Bold 9 with Borders, however, the employee ID list is showing as normal text.

4. Whenever I'm running the code, it's showing 'Unique Records' after three blank cells in LOA Report header of Unique Records worksheet, which is not looking good and obviously not required.

I'm 100% sure that you'll be able to mold the cold per my requirements. Thanks Trowa for your time and support in making this thing possible :-)

Regards
Kamal
0
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Nov 21, 2011 at 09:46 AM
Hi Kamal,

Thanks for your confidence.

1. Fixed. See if it works for you.

2. How many rows do you use as header? I assumed one row.

3. Fixed. I thought the employee ID were already formatted on the sheet they came from.

4. In your previous post you typed "Unique Records" with capitals only, so I changed it in the code. So make sure the sheets name "Unique Records" has the same capitalizations as the reference in the code.

Here is the code: 
Sub test()
Dim ws As Worksheet
Dim lRow As Integer
Dim x As Integer
Dim y As Integer

For Each ws In Worksheets
If ws.Name = "UNIQUE RECORDS" Then GoTo Nxt
lRow = ws.Range("E" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("E2:E" & lRow)
cell.Copy Destination:=Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Next cell
Nxt:
Next ws

Sheets("UNIQUE RECORDS").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

x = Range("A" & Rows.Count).End(xlUp).Row
y = 2
Do
If Cells(x, 1).Value = Cells(x - 1, 1) Then Cells(x, 1).EntireRow.ClearContents
x = x - 1
Loop Until x = y

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

End Sub

Keep up the clear way of explaining what you like to see happen. It really helps.

Best regards,
Trowa
0
Answer 6 / 29
Kamal
Nov 25, 2011 at 01:10 PM
Trowa,

Thanks for your response.

Please know that an error is occuring whenever I'm trying to run the new code. If I'm clicking on 'Debug' option, it's taking me to the below line:

If Cells(x, 1).Value = Cells(x - 1, 1) Then

Please look into it and check why we are getting this error. You may reach out to me if you need any further information.

Thanks & Regards
Kamal Hasan
0
Answer 7 / 29
Kamal
Dec 2, 2011 at 01:56 PM
Hey Trowa,

I'm not able to see your comments you posted on my observation dated Nov 25, 2011.

Can you please post them again so that I can check if the code is working fine for me?

Thanks for your time and support :-)
0
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Dec 8, 2011 at 10:26 AM
Sorry Kamal for the late response.

I can recreate the error by clearing column E of its contents. Therefore there is nothing to copy, thus nothing to compare, thus giving the error.

Made some slight changes to the code: 
Sub test()
Dim ws As Worksheet
Dim lRow As Integer
Dim x As Integer
Dim y As Integer

For Each ws In Worksheets
If ws.Name = "UNIQUE RECORDS" Then GoTo Nxt
lRow = ws.Range("E" & Rows.Count).End(xlUp).Row
If lRow = 1 Then GoTo Nxt
For Each cell In ws.Range("E2:E" & lRow)
If cell.Value <> "" Then cell.Copy Destination:=Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Next cell
Nxt:
Next ws

Sheets("UNIQUE RECORDS").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

x = Range("A" & Rows.Count).End(xlUp).Row
If x < 3 Then GoTo Nxt2
y = 2
Do
If Cells(x, 1).Value = Cells(x - 1, 1) Then Cells(x, 1).EntireRow.ClearContents
x = x - 1
Loop Until x = y

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

Nxt2:

End Sub

Try to create an error now :-)

Best regards,
Trowa
0
Answer 8 / 29
Kamal
Dec 9, 2011 at 06:55 AM
Trowa,

Thanks for your response.

Just wanted to let you know that the current code is just providing me a single partner which is in NOLOAD AND RTW_RECORDS sheet.

For your information, I've copied the code by dong ALT+F11 and pasting it in Sheet 4 (UNIQUE RECORDS). After this, I went to UNIQUE RECORDS sheet, put my cursor on A2 cell and pressing ALT + F8 and Run.

These are the employess listed in Column E for the following sheets:

NOLOAD SHEET EMPLOYEES
1009030
1013303
1014945
1022432
1028553
1029906
1030447
1035818
1036327
1039040

RTW_RECORDS SHEET EMPLOYEES
1046978
1014945
1036327
1009030
1064107
1092834
1097210
1101228
1110321

GOOD SHEET EMPLOYEES
1064107
1092834
1095348
1110321
1111511
1176746
1194340

The code will provide the following employees along with their sheet name:

1009030
1013303
1014945
1022432
1028553
1029906
1030447
1035818
1036327
1039040
1046978
1064107
1092834
1097210
1101228
1110321
1095348
1111511
1176746
1194340

Imp. Note: NOLOAD employees can trump employees from RTW_RECORDS and GOOD sheets.
0
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Dec 13, 2011 at 10:40 AM
And that is the result you wanted, right?

A general code like this one is usually put in a module instead of a sheet, although it doesn't matter much. ( a module is created by going to top menu of Visual Basic, selecting Insert > Module).

Best regards,
Trowa
0
Answer 9 / 29
Kamal Hasan
Jan 5, 2012 at 08:33 AM
Sorry for replying you so late, Trowa. Actually, I was quite busy due to some family emergencies for a couple of weeks.

God blessed me with a baby gal last week :-)

Coming over to your last response. Yes, I want the result mentioned in my last comments. I have used the last code you provided, however, it's just pulling-up a single employee i.e. 1009030 and report name i.e. NOLOAD. You can see that it's the first employee of NOLOAD and RTW_RECORDS sheets.

Please suggest if we can tweak the code further to provide the above list of partners.

Thanks
0
Answer 10 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Jan 16, 2012 at 09:00 AM
Hi Kamal,

Congrats on the expansion of your family!

I've been ill for the past three weeks from a nasty virus, so please accept my apologies for my late response.

Back to the topic, I'm not sure what you are trying to say.
"it's just pulling-up a single employee i.e. 1009030 and report name i.e. NOLOAD. You can see that it's the first employee of NOLOAD and RTW_RECORDS sheets."
Isn't this what you wanted?, because in your last post you said:
"NOLOAD employees can trump employees from RTW_RECORDS and GOOD sheets."

So 1009030 comes from NOLOAD and RTW_RECORDS, but because NOLOAD trumps RTW_RECORDS only the NOLOAD remains.

When I import the numbers into my workbook and run the code the same list appears. The only difference is that the below result list is sorted on the first column from small to big: 

1009030	NOLOAD
1013303	NOLOAD
1014945	NOLOAD
1022432	NOLOAD
1028553	NOLOAD
1029906	NOLOAD
1030447	NOLOAD
1035818	NOLOAD
1036327	NOLOAD
1039040	NOLOAD
1046978	RTW_RECORDS
1064107	RTW_RECORDS
1092834	RTW_RECORDS
1095348	GOOD
1097210	RTW_RECORDS
1101228	RTW_RECORDS
1110321	RTW_RECORDS
1111511	GOOD
1176746	GOOD
1194340	GOOD


Could you re-explain what you like to see different?

Best regards,
Trowa
0
Answer 11 / 29
Kamal Hasan
Jan 17, 2012 at 12:16 PM
Hey Trowa

Sorry to know about your illness. Hope you are doing well now :-)

You are getting the exact result by running the code. However, I'm just getting a single employee by running the code. Not sure if there's some deviations you made in the code.

Please provide me the code you used to extract the result you mentioned in your comments. Also, please mention the steps you are following to get the desired result.

I'm just getting the partner highlighted in bold, however, I want the complete list as shown below:

1009030 NOLOAD
1013303 NOLOAD
1014945 NOLOAD
1022432 NOLOAD
1028553 NOLOAD
1029906 NOLOAD
1030447 NOLOAD
1035818 NOLOAD
1036327 NOLOAD
1039040 NOLOAD
1046978 RTW_RECORDS
1064107 RTW_RECORDS
1092834 RTW_RECORDS
1095348 GOOD
1097210 RTW_RECORDS
1101228 RTW_RECORDS
1110321 RTW_RECORDS
1111511 GOOD
1176746 GOOD
1194340 GOOD

Thanks & Regards
Kamal Hasan
0
Answer 12 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Jan 19, 2012 at 09:25 AM
Hi Kamal,

Not sure what is going on.

Let me post my workbook with code (macro: test) and see if you can find the difference between my and your workbook which makes the code run incorrectly:

http://speedy.sh/mxJ3t/Kamal-Unique-records.xls

If you can't find a reason, then please upload (a sample of) your workbook, so I can try to find an inconsistency.

Best regards,
Trowa
0
Answer 13 / 29
Kamal Hasan
Jan 19, 2012 at 11:51 AM
Good news Trowa, it's working now. Thanks a ton for your time and support !!

There was some changes in the code I guess that was preventing it to run correctly.

Just a couple of things want to check if you can add it to the code:

1. Can all the sheet names appear in order i.e. first all NOLOAD sheet employees, than RTW_RECORDS sheet employee and finally GOOD sheet employee?

2. Can we add the filter option to the result we'll get by default everytime?

3. Can we add three more sheets in the workbook named 'NOACTION', 'INTERMITTEN_FMLA_RETURN_TO_WORK' and 'MULT_RTW'?

Note: We might not receive employees in 'MULT_RTW' and 'NOACTION' sheets. So the option in the code should be flexible, if employee(s) is there in these sheets, it will pull out the unique ones else no need to check.

Note: There's one more catch, Trowa with one of the above sheets. In 'INTERMITTEN_FMLA_RETURN_TO_WORK' sheet, the employees are listed in Column 'A' rather than Column 'E'.

Please let me know if you require any futher information from me regarding the above sheets.

Thanks & Regards
Kamal Hasan
0
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Jan 23, 2012 at 09:38 AM
Hi Kamal,

Good to see it's working.
Will need a liitle bit more time, just a quick question for now:
What will the order be with addition of 'NOACTION', 'INTERMITTEN_FMLA_RETURN_TO_WORK' and 'MULT_RTW'.

Will it be NOLOAD, RTW_RECORDS, GOOD, NOACTION, INTERMITTEN_FMLA_RETURN_TO_WORK, MULT_RTW?

Best regards,
Trowa
0
Answer 14 / 29
Kamal Hasan
Jan 25, 2012 at 07:25 AM
Hi Trowa

Thanks for your response.

There's no hurry, so you can take your time in modifying the code.

Yes, you mentioned the order correctly. Actually, INTERMITTEN_FMLA_RETURN_TO_WORK and MULT_RTW would be optional sheets as it might have some employees. Usually, we receive 2-3 employees in INTERMITTEN_FMLA_RETURN_TO_WORK and 1-2 employees in MULT_RTW sheet. So I want to place them last in the order.

Trowa, the biggest challenge you might face in modifying the code is comparing the employees from `INTERMITTEN_FMLA_RETURN_TO_WORK' sheet as the employees are listed in Column 'A' rather than Column 'E' for all other sheets. However, I'm sure you'll tweak the code accordingly.

Please let me know if you require any further information about the sheets.

Thanks & Regards
Kamal Hasan
0
Answer 15 / 29
Kamal Hasan
Jan 25, 2012 at 07:27 AM
Hi Trowa

Thanks for your response.

No hurry, you can take your time in modifying the code.

Yes, you mentioned the order correctly. Actually, INTERMITTEN_FMLA_RETURN_TO_WORK and MULT_RTW would be optional sheets as it might have some employees. Usually, we receive 2-3 employees in INTERMITTEN_FMLA_RETURN_TO_WORK and 1-2 employees in MULT_RTW sheet. So I want to place them last in the order.

Trowa, the biggest challenge you might face while modifying the code is comparing the employees from `INTERMITTEN_FMLA_RETURN_TO_WORK' sheet as the employees are listed in Column 'A' rather than Column 'E' for all other sheets. However, I'm sure you'll tweak the code accordingly.

Please let me know if you require any further information about the sheets.

Thanks & Regards
Kamal Hasan
0
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Jan 30, 2012 at 09:40 AM
Hi Kamal,

Let's go through the points you mentioned in your "Jan 19" post.

2. The code will now check if there is an autofilter applied, if not then it will be added.

3. The code will check column E of every sheet in workbook. With two exceptions:
In sheet "INTERMITTEN_FMLA_RETURN_TO_WORK" column A will be checked and sheet "UNIQUE RECORDS" will not be checked.

1. This is actually the most tricky one. I was thinking about the following solution.
A) Using the autofilter, filter on "NOLOAD". Copy-paste results to a temporary location.
Then filter on "RTW_RECORDS". Copy-paste results below the "NOLOAD" ones.
etc. for the rest of the sheet names.
Then cut-paste the results from the temporary location to the original location.

B) Another solution would be to add a letter or a number in front of the sheets name in order to sort the data the way you want to.

My question is: What would be a good temporary location?, i.e. an empty space on your "UNIQUE RECORDS" sheet.
Or would you rather go for option B?

Here is the code as it is now: 
Sub Test()
Dim ws As Worksheet
Dim lRow As Integer
Dim cCol As Integer
Dim x As Integer
Dim y As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
If ws.Name = "UNIQUE RECORDS" Then GoTo Nxt
cCol = 5
If ws.Name = "INTERMITTEN_FMLA_RETURN_TO_WORK" Then cCol = 1
lRow = ws.Cells(Rows.Count, cCol).End(xlUp).Row
Sheets(ws.Name).Select
For Each cell In Range(Cells(2, cCol), Cells(lRow, cCol))
cell.Copy Destination:=Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("UNIQUE RECORDS").Select
Range("A" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Next cell
Nxt:
Next ws

Sheets("UNIQUE RECORDS").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

x = Range("A" & Rows.Count).End(xlUp).Row
y = 2
Do
If Cells(x, 1).Value = Cells(x - 1, 1) Then Cells(x, 1).EntireRow.ClearContents
x = x - 1
Loop Until x = y

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal
  
If Sheets("UNIQUE RECORDS").AutoFilterMode Then
    ison = "On"
Else
    ison = "Off"
End If
If ison = "Off" Then Range("A1:B1").AutoFilter

Application.ScreenUpdating = True
End Sub


Kind regards,
Trowa
0
Answer 16 / 29
Kamal Hassan
Jan 31, 2012 at 02:31 PM
Thanks Trowa for your response.

The code is now providing the auto filter option. So thanks for this.

I think we can use the empty space of "UNIQUE RECORDS" sheet, however, the code result will just provide and show two columns i.e. Partner_IDs and LOA Report. The calculation or anything will not be visible in "UNIQUE RECORDS" sheet at the time of code results.

Please let me know if you have any further questions.

Thanks & Regards
Kamal Hassan
0
Answer 17 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Feb 2, 2012 at 10:02 AM
Hi Kamal,

See if the following code fulfills your every request: 

Sub Test()
Dim ws As Worksheet
Dim lRow, lRow2, lRow3 As Integer
Dim cCol As Integer
Dim x, y As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "UNIQUE RECORDS" Then GoTo Nxt
cCol = 5
    If ws.Name = "INTERMITTEN_FMLA_RETURN_TO_WORK" Then cCol = 1
lRow = ws.Cells(Rows.Count, cCol).End(xlUp).Row
Sheets(ws.Name).Select
        For Each cell In Range(Cells(2, cCol), Cells(lRow, cCol))
cell.Copy Destination:=Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("UNIQUE RECORDS").Select
Range("A" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
        Next cell
Nxt:
Next ws

Sheets("UNIQUE RECORDS").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

x = Range("A" & Rows.Count).End(xlUp).Row
y = 2

    Do
        If Cells(x, 1).Value = Cells(x - 1, 1) Then Cells(x, 1).EntireRow.ClearContents
        x = x - 1
    Loop Until x = y

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal
  
    If Sheets("UNIQUE RECORDS").AutoFilterMode Then
        ison = "On"
    Else
        ison = "Off"
    End If
    If ison = "Off" Then Range("A1:B1").AutoFilter

lRow3 = Range("A" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="NOLOAD"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 100)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="RTW_RECORDS"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="GOOD"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="NOACTION"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="INTERMITTEN_FMLA_RETURN_TO_WORK"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="MULT_RTW"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

Selection.AutoFilter Field:=2

lRow2 = Range("C1").End(xlDown).Row
lRow3 = Range("C" & Rows.Count).End(xlUp).Row

Range(Cells(lRow2, "C"), Cells(lRow3, "D")).Cut Destination:=Range("A2")

lRow2 = Range("A" & Rows.Count).End(xlUp).Row

Range("A2:B" & lRow2).Select

    Range("A2:B28").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

Application.ScreenUpdating = True
End Sub

Kind regards,
Trowa
0
Answer 18 / 29
Kamal Hasan
Feb 7, 2012 at 02:27 PM
Hey Trowa,

The above code is fetching the below results:

Partner_IDs -> First column
1009030
1013303
1014945
1022432
1028553
1029906
1030447
1035818
1036327
1039040
1066894
1073290
1075980
1076321
1082217
1084579
1086247
1097210
1099550
1100789
1101228
1101598
1121076
1150794
1151598
1152758
1156020
1157122
1162884
1165450
1165758
1169311
1172810
1175053
1176438
1179870
1179963
1184408
1186718
1188080
1189843
1191387
1192501
1194708
1046978
1064107
1092834
1110321
1111511
1150700
1176746
1194340
1095348
Partner_IDs
Partner_IDs1086036


LOA Report-> Second column
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
NOLOAD
RTW_RECORDS
RTW_RECORDS
RTW_RECORDS
RTW_RECORDS
RTW_RECORDS
RTW_RECORDS
RTW_RECORDS
RTW_RECORDS
GOOD
LOA Report
LOA ReportMULT_RTW


As I cannot provide you the excel sheet, I'm providing you the data coming in under different columns i.e. Partner_IDs and LOA Report.

Please let me know if this code can be corrected further to provide the desired results.

The errors are highlighted in italic font. Please note that NOLOAD employees can trump partners appearing in any other sheet.

Thanks
Kamal Hasan
0
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Feb 9, 2012 at 09:51 AM
Hi Kamal,

Could you provide the Partner ID's per sheet?
With that data I can check if I get the same result as you showed me above.
Also let me know at which row the data starts; Is it always row number 2 for every sheet?

Kind regards,
Trowa
0
Answer 19 / 29
Kamal Hasan
Feb 9, 2012 at 11:22 AM
NOLOAD - Column E
1009030
1013303
1014945
1022432
1028553
1029906
1030447
1035818
1036327
1039040
1066894
1073290
1075980
1076321
1082217
1084579
1086247
1097210
1099550
1100789
1101228
1101598
1121076
1150794
1151598
1152758
1156020
1157122
1162884
1165450
1165758
1169311
1172810
1175053
1176438
1179870
1179963
1184408
1186718
1188080
1189843
1191387
1192501
1194708

RTW_RECORDS - Column E
1009030
1014945
1036327
1046978
1064107
1092834
1097210
1101228
1110321
1111511
1150700
1152758
1162884
1176746
1179963
1189843
1192501
1194340
1194708

GOOD - Column E
1064107
1092834
1095348
1110321
1111511
1176746
1194340

NOACTION - Column E
1175053

INTERMITTEN_FMLA_RETURN_TO_WORK - Column A
1179963
1192501

MULT_RTW - Column E
1086036

After that there's UNIQUE RECORDS sheet in which the result appears and I've already shared the results with you in my last comments. Yes, the data starts from row 2 in every sheet.

You can also provide me the spreadsheet after working on the above data so the I can get the exact idea if the result is providing correct data.

Pelase let me know if you require any further information.

Thanks
Kamal Hasan
0
Answer 20 / 29
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Feb 13, 2012 at 09:58 AM
Hi Kamal,

My bad, I tested with unique values in each sheet. Now I see that when there aren't any unique values it would copy the header.

I also noticed that the borders weren't doing qhat they were supposed to do.

See if this code works correctly: 
Sub Test()
Dim ws As Worksheet
Dim lRow, lRow2, lRow3 As Integer
Dim cCol As Integer
Dim x, y As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "UNIQUE RECORDS" Then GoTo Nxt
cCol = 5
    If ws.Name = "INTERMITTEN_FMLA_RETURN_TO_WORK" Then cCol = 1
lRow = ws.Cells(Rows.Count, cCol).End(xlUp).Row
Sheets(ws.Name).Select
        For Each cell In Range(Cells(2, cCol), Cells(lRow, cCol))
cell.Copy Destination:=Sheets("UNIQUE RECORDS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("UNIQUE RECORDS").Select
Range("A" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
Sheets("UNIQUE RECORDS").Range("B" & Rows.Count).End(xlUp).Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 9
        .Font.Bold = True
    End With
        Next cell
Nxt:
Next ws

Sheets("UNIQUE RECORDS").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

x = Range("A" & Rows.Count).End(xlUp).Row
y = 2

    Do
        If Cells(x, 1).Value = Cells(x - 1, 1) Then Cells(x, 1).EntireRow.ClearContents
        x = x - 1
    Loop Until x = y

Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal

    If Sheets("UNIQUE RECORDS").AutoFilterMode Then
        ison = "On"
    Else
        ison = "Off"
    End If
    If ison = "Off" Then Range("A1:B1").AutoFilter

lRow3 = Range("A" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="NOLOAD"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 100)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="RTW_RECORDS"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="GOOD"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="NOACTION"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="INTERMITTEN_FMLA_RETURN_TO_WORK"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

lRow3 = Range("C" & Rows.Count).End(xlUp).Row
Selection.AutoFilter Field:=2, Criteria1:="MULT_RTW"
lRow2 = Range("A" & Rows.Count).End(xlUp).Row
If lRow2 <> 1 Then Range("A2:B" & lRow2).Copy Destination:=Range("C" & lRow3 + 1)

Selection.AutoFilter Field:=2

lRow2 = Range("C1").End(xlDown).Row
lRow3 = Range("C" & Rows.Count).End(xlUp).Row

Range(Cells(lRow2, "C"), Cells(lRow3, "D")).Cut Destination:=Range("A2")

lRow2 = Range("A" & Rows.Count).End(xlUp).Row

Range("A2:B" & lRow2).Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

Application.ScreenUpdating = True
End Sub

With this code I get the following result:

1009030 NOLOAD
1013303 NOLOAD
1014945 NOLOAD
1022432 NOLOAD
1028553 NOLOAD
1029906 NOLOAD
1030447 NOLOAD
1035818 NOLOAD
1036327 NOLOAD
1039040 NOLOAD
1066894 NOLOAD
1073290 NOLOAD
1075980 NOLOAD
1076321 NOLOAD
1082217 NOLOAD
1084579 NOLOAD
1086247 NOLOAD
1097210 NOLOAD
1099550 NOLOAD
1100789 NOLOAD
1101228 NOLOAD
1101598 NOLOAD
1121076 NOLOAD
1150794 NOLOAD
1151598 NOLOAD
1152758 NOLOAD
1156020 NOLOAD
1157122 NOLOAD
1162884 NOLOAD
1165450 NOLOAD
1165758 NOLOAD
1169311 NOLOAD
1172810 NOLOAD
1175053 NOLOAD
1176438 NOLOAD
1179870 NOLOAD
1179963 NOLOAD
1184408 NOLOAD
1186718 NOLOAD
1188080 NOLOAD
1189843 NOLOAD
1191387 NOLOAD
1192501 NOLOAD
1194708 NOLOAD
1046978 RTW_RECORDS
1064107 RTW_RECORDS
1092834 RTW_RECORDS
1110321 RTW_RECORDS
1111511 RTW_RECORDS
1150700 RTW_RECORDS
1176746 RTW_RECORDS
1194340 RTW_RECORDS
1095348 GOOD
1086036 MULT_RTW

Kind regards,
Trowa
0
  • 1
  • 2

Similar discussions

Confirm your identity with phone or computer
Sajibdas217@gmail.com -
ElenaKM -

1 response
Excel - To generate unique ID
wliang -
ferg -

4 responses
How to generate a STATIC unique identifier for each Excel row
Musicar -
ac3mark -

4 responses
Facebook message show confirm your identity
Shehryar01 -
Ambucias -

7 responses
Autogenerate alphanumeric ID numbers in Excel?
NoTechKnowledge64 -
vcoolio -

3 responses