Copy rows based on a criteria

[cubexparts]

Hi Guy's.

My name is Jan and I need your assistance please.

I have a file with a macro that is giving me a "run-time error 13" notification.

Your assistance will be highly appreciated.

Thanks

Jan

 

[NARAYANK991]

Hi ,

The uploaded file does not have the macro ; can you please post the macro , or even better , upload the workbook with the code in it ?

Narayan

 

[cubexparts]

Hi ,

The uploaded file does not have the macro ; can you please post the macro , or even better , upload the workbook with the code in it ?

Narayan

Hi Narayan

Sorry about that. Here is the macro.

Sub ReorgData()
Dim LR As Long, a As Long, SR As Long, ER As Long
Application.ScreenUpdating = False
Rows(1).Insert
Range("A1") = "TitleA"
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(5), Unique:=True
LR = Range("E" & Rows.Count).End(xlUp).Row
For a = 2 To LR Step 1
SR = Application.Match(Range("E" & a), Columns(1), 0)
ER = Application.Match(Range("E" & a), Columns(1), 1)
If SR = ER Then
Range("F" & a) = Range("B" & SR)
Else
Range("F" & a).Resize(, ER - SR + 1).Value = Application.Transpose(Range("B" & SR & ":B" & ER).Value)
End If
Next a
Rows(1).Delete
Application.ScreenUpdating = True
End Sub


Thanks
Jan

 

[cubexparts]

Hi Narayan

Sorry about that. Here is the macro.

Sub ReorgData()
Dim LR As Long, a As Long, SR As Long, ER As Long
Application.ScreenUpdating = False
Rows(1).Insert
Range("A1") = "TitleA"
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(5), Unique:=True
LR = Range("E" & Rows.Count).End(xlUp).Row
For a = 2 To LR Step 1
SR = Application.Match(Range("E" & a), Columns(1), 0)
ER = Application.Match(Range("E" & a), Columns(1), 1)
If SR = ER Then
Range("F" & a) = Range("B" & SR)
Else
Range("F" & a).Resize(, ER - SR + 1).Value = Application.Transpose(Range("B" & SR & ":B" & ER).Value)
End If
Next a
Rows(1).Delete
Application.ScreenUpdating = True
End Sub


Thanks
Jan

 

[NARAYANK991]

Hi ,

I am sorry but I am not in a position to rectify the problem now. I hope someone else can help out.

The problem is the length of the strings in column B , which in quite a few places are exceeding the limit of 255 characters.

Narayan

 

[cubexparts]

h

Hi ,

I am sorry but I am not in a position to rectify the problem now. I hope someone else can help out.

The problem is the length of the strings in column B , which in quite a few places are exceeding the limit of 255 characters.

Narayan

Hi

Thank you very much for your assistance.

Based on your feedback I have managed to do a workaround with the desired results.

Regards

Jan