Need help with macros code

Hi to everyone.

I need help with this code.

 

I have an excel with four pages (page1,pageB,pageC and pageD), the last 3 pages are empty, and the firstone has this:

 

            A            B                      C                   D

     1     5      3ºoption          1ºoption       2ºoption

     2     4      2ºoption          3ºoption       1ºoption   

     3     3      1ºoption          3ºoption       2ºoption 

     4     2      1ºoption          2ºoption       3ºoption 

     5     1      2ºoption          1ºoption       3ºoption 

 

I need this: A VBA code that read the cells from b1 to d1 (completes all the code and then from b2 to d2 and then from b3 to d3 and so on), and determine wich one has the lowest option(1ºoption is the lowest, and 3ºoption is the highest) and based on which column is the 1ºoption, copy the readed row or cells(b1 to d1) and paste it into the page wich has the name of where is the 1option, in the case of the first row, it will be in pageC.

But wait a minute, the number of rows that can be copied within each page is limited. (for example in PageB = 1, PageC = 2 and in PageD = 2)

So it has to do this:

It start from the first row, read cells b1,c1,d1 and determines wich has the lowest option (1ºoption) so in this case, the 1ºoption is on the column C, so then it copy the row, and past it on PageC. Remember that the max number of rows to be copied into the pages, are limited, so in this case, PageC=2, then now, is = 1.

Ok lest move on, now goes to the second row, and reads b2,c2,d2, make the same as the first row, determines wich and where is the lowest option, in this case is on the column D,  so then it copy the row, and past it on PageD. PageD=2, then now is = 1.

Now, goes to the third row, and reads b3,c3,d3, determines wich and where is the lowest option, in this case is on the column B,  so then it copy the row, and past it on PageB. PageB=1, then now is = 0. Now, here the limit is full, lets see what happend in the next row.

Now, goes to the fourth row, and reads b4,c4,d4, determines wich and where is the lowest option, in this case is on the column B,  but remember that the limit of rows in PageB is full, so it cant be copied into that page, so here goes from low to high, let me explain: The PaceB is full, the row4 cant be copied into her first option (1ºoption) so going from low from high, the next should be the second option (2ºoption) so now, the second option of the row 4 is on the column C, and in PageC, the original limit was 2, but we allready copied the row 1 in there, so there still one space on PageC. So the row 4 goes to PageC, and now PageC has fulled his limit. PageC original limit=2, but we copied the first and the fourth rows in there.

Now move on to the last row.

Now, goes to the fifth row, and reads b5,c5,d5, determines wich and where is the lowest option, in this case is on the column C, but PageC limit is full, so its takes his second option (2ºoption) wich is under the B column, but the PageB limit is also full, so it has to take his third option (3ºoption) wich is under the D column. Now, the origianl PageD limit was = 2, but we already copied one row there, the secondone, so it change the limit from 2 to 1. So there still 1 space to copy the fifth row there, so the fifth row will be copied into the PageD.

 

 

So the final reult, should look like this:

On pageB is this:

Row 3

 

On pageC is this:

Row 1

Row 4

 

On pageD is this:

Row 2

Row 5

 

Here I got a picture with a diagram I did to try to explain it better

 subefotos.com/ver/?d8ff1ecb924cba29f2cee43200f0115ao.jpg

Dollar sign

Without Dollar sign the code works for me. If it works for you with Dollar sign, fine.

try Changing the type of variables

Glad that you like my code.
The line that you have mentioned is working fine for the no of lines of data that you have provided.
If the number of lines are more, then you may try by changing as given below:
Dim ctr As Long
Dim rolr As Long
I dont receive notification of your reply by email from this site.
I just opened the forum and clicked your query and found that you have responded.

Find In Sh1 Copy In ShB ShC ShD

You may try this. Some expert may give a shorter and better code. But, for the time being, this works.
Private Sub cmdFindInSh1CopyInShBShCShD_Click()
Dim ctr As Integer
Dim rolr As Integer
Dim TrgtShNam As String
Dim LstRow As Long
Dim NowRow As Long
Dim SelRange As Range
Dim arr1() As String
Dim arr2() As String
Dim arrTest(1)
Dim sTxt1$, sTxt2$
NowRow = 2
Worksheets("B").Cells.ClearContents
Worksheets("C").Cells.ClearContents
Worksheets("D").Cells.ClearContents
Sheets("Sheet1").Select
Range("b" & Trim(Str(NowRow))).Select
Do While Selection.Value <> ""
Set SelRange = Range("A" & Trim(Str(NowRow)) & ":D" & Trim(Str(NowRow)))
For rolr = 0 To 2
ctr = Left(Selection.Offset(0, rolr).Value, 1)
If Len(sTxt1) > 0 Then
sTxt1 = sTxt1 & "," & ctr
Else
sTxt1 = ctr
End If
If Len(sTxt2) > 0 Then
sTxt2 = sTxt2 & "," & Mid(Selection.Offset(0, rolr).Address, 2, 1)
Else
sTxt2 = Mid(Selection.Offset(0, rolr).Address, 2, 1)
End If
Next
arr1 = Split(sTxt1, ",")
arr2 = Split(sTxt2, ",")
arrTest(0) = arr1()
arrTest(1) = arr2()
ChkAgn:
If (arrTest(0)(0) < arrTest(0)(1)) And (arrTest(0)(0) < arrTest(0)(2)) Then
TrgtShNam = arrTest(1)(0)
ElseIf (arrTest(0)(1) < arrTest(0)(0)) And (arrTest(0)(1) < arrTest(0)(2)) Then
TrgtShNam = arrTest(1)(1)
ElseIf (arrTest(0)(2) < arrTest(0)(0)) And (arrTest(0)(2) < arrTest(0)(1)) Then
TrgtShNam = arrTest(1)(2)
End If
Sheets(TrgtShNam).Select
LstRow = Sheets(TrgtShNam).Range("A" & Rows.Count).End(xlUp).Row
Range("A" & Trim(Str(LstRow))).Select
If TrgtShNam = "B" Then
If LstRow <= 1 And Selection.Value = "" Then
SelRange.Copy Range("A" & Trim(Str(LstRow)))
Else
arrTest(0)(0) = 4
GoTo ChkAgn
End If
ElseIf (TrgtShNam = "C") Or (TrgtShNam = "D") Then
If LstRow <= 2 And Selection.Value = "" Then
SelRange.Copy Range("A" & Trim(Str(LstRow)))
Else
Selection.Offset(1, 0).Select
If ActiveCell.Row = 2 And Selection.Value = "" Then
SelRange.Copy Range("A" & Trim(Str(LstRow + 1)))
Else
If TrgtShNam = "C" Then
arrTest(0)(1) = 4
ElseIf TrgtShNam = "D" Then
arrTest(0)(2) = 4
End If
GoTo ChkAgn
End If
End If
End If
sTxt1 = ""
sTxt2 = ""
Sheets("Sheet1").Select
Range("b" & Trim(Str(NowRow))).Select
Selection.Offset(1, 0).Select
NowRow = NowRow + 1
Loop
End Sub

Editing your code

How can i edit in your code the following things:
The limit of row par page of the B,C and D Pages
And how can i add another column of option,example:
E column with 4ºoption

Thanks for you reply

Edited: Allready fixit, thanks!!

First off all, thanks for your help and time.
It give me this error your code:
type mismatch
On this line:
ctr = Left(Selection.Offset(0, rolr).Value, 1)

Can you help me to resolve?

Again, thanks

Almir's picture

Maybe dollar sign?

ctr = Left$(Selection.Offset(0, rolr).Value, 1)

Almir's picture

Maybe dollar sign?

ctr = Left$(Selection.Offset(0, rolr).Value, 1)

Almir's picture

Maybe dollar sign?

ctr = Left$(Selection.Offset(0, rolr).Value, 1)