VB Code for equal assignment

[MaheshBabu]

Hi Every1,

I have 3 columns in an excel sheet (ID, Signed by & To be checked), and in another sheet, I have names under a column "Checkers".

I need a macro where in if I run it "To be checked" column in sheet 1 should be equally assigned to the "Checkers" in sheet 2 and the rest should be blanks.

Some1 help me with the macro.

Please find the below sample:

Before Macro:

[TABLE="width: 241"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]ID[/TD]
[TD]Signed by[/TD]
[TD]To be Checked[/TD]
[/TR]
[TR]
[TD]121[/TD]
[TD]AAA[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]BBB[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]CCC[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]125[/TD]
[TD]AAA[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]126[/TD]
[TD]BBB[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]127[/TD]
[TD]CCC[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]128[/TD]
[TD]DDD[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]129[/TD]
[TD]AAA[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]130[/TD]
[TD]EEE[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]131[/TD]
[TD]DDD[/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]

After Macro :

[TABLE="width: 241"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]Loan #[/TD]
[TD]Signed by[/TD]
[TD]To be Checked[/TD]
[/TR]
[TR]
[TD]121[/TD]
[TD]AAA[/TD]
[TD]Don[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]BBB[/TD]
[TD]Don[/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]CCC[/TD]
[TD]Don[/TD]
[/TR]
[TR]
[TD]125[/TD]
[TD]AAA[/TD]
[TD]Adam[/TD]
[/TR]
[TR]
[TD]126[/TD]
[TD]BBB[/TD]
[TD]Adam[/TD]
[/TR]
[TR]
[TD]127[/TD]
[TD]CCC[/TD]
[TD]Adam[/TD]
[/TR]
[TR]
[TD]128[/TD]
[TD]DDD[/TD]
[TD]Rose[/TD]
[/TR]
[TR]
[TD]129[/TD]
[TD]AAA[/TD]
[TD]Rose[/TD]
[/TR]
[TR]
[TD]130[/TD]
[TD]EEE[/TD]
[TD]Rose[/TD]
[/TR]
[TR]
[TD]131[/TD]
[TD]DDD[/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]

 

[taurean]

I have modified hiker95's code slightly to adjust with change in data. Replace previous code with this one.

Option Explicit
Sub AssignCheckers()
' hiker95, 11/06/2013
' edited by taurean, 11/07/2013
' http://www.mrexcel.com/forum/excel-questions/737261-vbulletin-code-equal-assignment.html
Dim a As Variant, c As Variant
Dim i As Long, n As Long
With Sheets("Sheet2")
  c = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
With Sheets("Sheet1")
  a = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row)
  n = Application.Floor(UBound(a, 1) / UBound(c, 1), 1)
  For i = LBound(c, 1) To UBound(c, 1)
    .Cells((i - 1) * n + 2, "C").Resize(n, 1).Value = c(i, 1)
  Next i
End With
End Sub

 

[hiker95]

taurean,

Very nicely done - thanks.

I was trying to resolve the present task by using arrays in memory, and, not writing directly to the worksheet.

Thanks again.

 

[Rick Rothstein]

I was trying to resolve the present task by using arrays in memory, and, not writing directly to the worksheet.

Something like this maybe...

Sub DistributeCheckers()
  Dim X As Long, Z As Long, PerChecker As Long, IDs As Variant, Checkers As Variant, OutArr As Variant
  IDs = Sheets("Sheet1").Range("A2:A" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
  Checkers = Sheets("Sheet2").Range("A2:A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row)
  PerChecker = Int(UBound(IDs) / UBound(Checkers))
  ReDim OutArr(1 To PerChecker * UBound(Checkers), 1 To 1)
  For X = 1 To PerChecker * UBound(Checkers) Step PerChecker
    For Z = 1 To PerChecker
      OutArr(X + Z - 1, 1) = Checkers(1 + ((X - 1) / PerChecker), 1)
    Next
  Next
  Sheets("Sheet1").Range("C2").Resize(UBound(OutArr)) = OutArr
End Sub

 

[hiker95]

Rick Rothstein,

Thanks again.


Rick Rothstein, taurean,

i want a code in such a way that if my ID's and No. of Checkers are not constant(It may increase/decrease) the ID's in sheet 1 should be equally assigned to the checkers in a given range of cells be it 'sheet2' are any where in the excel....and the rest of the rows should be blank....

Per MaheshBabu in reply #7.

If we play with the number of items in both column A's, both macros may fail.

 

[MaheshBabu]

Hi,

Thank you very much...code is working fine....

 

[MaheshBabu]

Thanx a mil dude....its working perfect.....

 

[hiker95]

MaheshBabu,

You are very welcome. Glad we could help.

And, come back anytime.