Need a macros that read a range of cells, determine low value, then do something else

Hi to everyone. :)

I need help with this: :confused:

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

I have the following code, but it doest do what i need, but maybe someone can modify it.

Here is the code:

Code:

---

Sub copiar()

    Dim PageB, PageC, PageD As Integer

    Dim contador As Integer

    contador = 1

    PageB= 0

    PageC= 0

    PageD= 0



    Do While contador <= 5

        Sheets("Page1").Select

        Select Case Range("B" & contador + 1).Value

            Case "1ºoption"

                If PageB < 1 Then

                    Range("B" & contador + 1 & ":D" & contador + 1).Select

                    Range("B" & contador + 1 & ":D" & contador + 1).Copy

                    Sheets("PageB").Select

                    Range("A" & PageB+ 1).Select

                    ActiveSheet.Paste

                    PageB= PageB + 1

                Else

                    If PageC < 2 Then

                        Range("B" & contador + 1 & ":D" & contador + 1).Select

                        Range("B" & contador + 1 & ":D" & contador + 1).Copy

                        Sheets("PageC").Select

                        Range("A" & PageC + 1).Select

                        ActiveSheet.Paste

                        PageC = PageC + 1

                    Else

                        If PageC < 2 Then

                            Range("B" & contador + 1 & ":D" & contador + 1).Select

                            Range("B" & contador + 1 & ":D" & contador + 1).Copy

                            Sheets("PageC").Select

                            Range("A" & PageC + 1).Select

                            ActiveSheet.Paste

                            PageC = PageC + 1

                        Else

                            MsgBox "The limit is full"

                            Exit Do

                        End If

                    End If

                End If

            Case "2ºoption"

                If PageC < 2 Then

                    Range("B" & contador + 1 & ":D" & contador + 1).Select

                    Range("B" & contador + 1 & ":D" & contador + 1).Copy

                    Sheets("PageC ").Select

                    Range("A" & PageC + 1).Select

                    ActiveSheet.Paste

                    PageC = PageC + 1

                Else

                    If PageB < 1 Then

                        Range("B" & contador + 1 & ":D" & contador + 1).Select

                        Range("B" & contador + 1 & ":D" & contador + 1).Copy

                        Sheets("PageB ").Select

                        Range("A" & PageB + 1).Select

                        ActiveSheet.Paste

                        PageB = PageB + 1

                    Else

                        If PageD < 2 Then

                            Range("B" & contador + 1 & ":D" & contador + 1).Select

                            Range("B" & contador + 1 & ":D" & contador + 1).Copy

                            Sheets("PageD ").Select

                            Range("A" & PageD + 1).Select

                            ActiveSheet.Paste

                            PageD = PageD + 1

                        Else

                            MsgBox "The limit is full"

                            Exit Do

                        End If

                    End If

                End If

            Case "3ºoption"

                If PageD < 2 Then

                    Range("B" & contador + 1 & ":D" & contador + 1).Select

                    Range("B" & contador + 1 & ":D" & contador + 1).Copy

                    Sheets("PageD ").Select

                    Range("A" & PageD + 1).Select

                    ActiveSheet.Paste

                    PageD = PageD + 1

                Else

                    If PageB < 1 Then

                        Range("B" & contador + 1 & ":D" & contador + 1).Select

                        Range("B" & contador + 1 & ":D" & contador + 1).Copy

                        Sheets("PageB ").Select

                        Range("A" & PageB + 1).Select

                        ActiveSheet.Paste

                        PageB = PageB + 1

                    Else

                        If PageC < 2 Then

                            Range("B" & contador + 1 & ":D" & contador + 1).Select

                            Range("B" & contador + 1 & ":D" & contador + 1).Copy

                            Sheets("PageC ").Select

                            Range("A" & PageC + 1).Select

                            ActiveSheet.Paste

                            PageC = PageC + 1

                        Else

                            MsgBox "The limit is full"

                            Exit Do

                        End If

                    End If

                End If

        End Select

        contador = contador + 1

    Loop

End Sub

---

can you attach a sample file with data and desired result ?

Hi, lautaroml,

maybe have a try with this code:

Code:

---

Sub VBA_Ex_49627()
Dim lngCounter As Long
Dim lngTarget As Long
Dim wsData As Worksheet
Dim wsTarg As Worksheet
Dim lngCol As Long
Dim rngCell As Range
Dim lngTemp As Long

Set wsData = Sheets("Page1")
For lngCounter = 1 To wsData.Range("A" & Rows.Count).End(xlUp).Row
  lngTemp = Columns.Count
  lngCol = 0
  For Each rngCell In wsData.Range("B" & lngCounter & ":D" & lngCounter)
    If Val(rngCell) < lngTemp Then
      lngTemp = Val(rngCell)
      lngCol = rngCell.Column
    End If
  Next rngCell
  With Sheets("Page" & Chr(64 + lngCol))
    lngTarget = .Range("A" & Rows.Count).End(xlUp).Row + 1
    If .Range("A1").Value = "" Then lngTarget = 1
    .Range("A" & lngTarget).Resize(1, 4).Value = wsData.Range("A" & lngCounter).Resize(1, 4).Value
  End With
Next lngCounter
End Sub

---

You would need to explain about the limitations of the copying as I haven´t realized how that may work.

Ciao,
Holger

…or this one

Code:

---

Sub blah()
Set DestSheets = Sheets(Array("pageB", "pageC", "pageD"))
Limits = Array("", 1, 2, 2)
DestnRow = Array("", 1, 1, 1)
For Each rw In Sheets("page1").Range("B1:D5").Rows
 v = Application.Index(rw.Value, 1, 0)
  If v(1) > v(2) Then temp = v(2): v(2) = v(1): v(1) = temp
  If v(2) > v(3) Then temp = v(2): v(2) = v(3): v(3) = temp
  If v(1) > v(2) Then temp = v(2): v(2) = v(1): v(1) = temp
  For i = 1 To 3
    x = Application.Match(v(i), rw, 0)
    If Limits(x) > 0 Then
      rw.Copy DestSheets(x).Cells(DestnRow(x), 1)
      DestnRow(x) = DestnRow(x) + 1
      Limits(x) = Limits(x) - 1
      Exit For
    End If
  Next i
Next rw
End Sub

---

Hi, lautaroml,

an update of the code tryaing to satisfy the restraints:

Code:

---

Sub VBA_Ex_49627_A()
Dim lngCounter As Long
Dim lngTarget As Long
Dim wsData As Worksheet
Dim wsTarg As Worksheet
Dim lngCol As Long
Dim rngCell As Range
Dim lngTemp As Long
Dim varArr(2 To 4) As Long
Dim varTemp(2 To 4) As Long

varArr(2) = 1      'upper limit for PageB
varArr(3) = 2      'upper limit for PageC
varArr(4) = 2      'upper limit for PageD
varTemp(2) = 0
varTemp(3) = 0
varTemp(4) = 0

Set wsData = Sheets("Page1")
For lngCounter = 1 To wsData.Range("A" & Rows.Count).End(xlUp).Row
  If lngCounter = 4 Then Stop
  lngTemp = Columns.Count
  lngCol = 0
  For Each rngCell In wsData.Range("B" & lngCounter & ":D" & lngCounter)
    If Val(rngCell) < lngTemp And varTemp(rngCell.Column) < varArr(rngCell.Column) Then
      lngTemp = Val(rngCell)
      lngCol = rngCell.Column
    End If
  Next rngCell
  varTemp(lngCol) = varTemp(lngCol) + 1
  With Sheets("Page" & Chr(64 + lngCol))
    lngTarget = .Range("A" & Rows.Count).End(xlUp).Row + 1
    If .Range("A1").Value = "" Then lngTarget = 1
    .Range("A" & lngTarget).Resize(1, 4).Value = wsData.Range("A" & lngCounter).Resize(1, 4).Value
  End With
Next lngCounter
End Sub

---

Ciao,
Holger

Sure, here it is:

Attachment 11675

Thanks for your time and help!!

Hi Holger, I really apriceciate your help and time!! For real!
Let me explain how the limitations works:
Each page must have a numeric value, which is defined by me. For example, page B has a value of 5.
Assuming that on that page, 5 rows can be copied in PageB. The limit of rows that can be copied to that page (the numbers of rows copied to a page, cant be bigger than the value number (5)) now is filled and thus next first options that are inside the "paginaB" column MUST be ignored and go to their second choices.
And in case the first options and second options are full, they MUST go to the third option.
I hope I was clear.
Many thanks for your help!

p45cal
Really thanks for your help and time! I really I appreciate it!!

i think that your code do what i need.
But i have 2 questions:

How to add to the pasted rows the A column.
And how to add another row that contains options, for example E row, like below:

	A	B	C	D	E
1	some text	3ºoption	1ºoption	2ºoption	4ºoption

Again, thanks for your time and help!!

Quote:

---

Originally Posted by p45cal

…or this one

Code:

---

Sub blah()
Set DestSheets = Sheets(Array("pageB", "pageC", "pageD"))
Limits = Array("", 1, 2, 2)
DestnRow = Array("", 1, 1, 1)
For Each rw In Sheets("page1").Range("B1:D5").Rows
 v = Application.Index(rw.Value, 1, 0)
  If v(1) > v(2) Then temp = v(2): v(2) = v(1): v(1) = temp
  If v(2) > v(3) Then temp = v(2): v(2) = v(3): v(3) = temp
  If v(1) > v(2) Then temp = v(2): v(2) = v(1): v(1) = temp
  For i = 1 To 3
    x = Application.Match(v(i), rw, 0)
    If Limits(x) > 0 Then
      rw.Copy DestSheets(x).Cells(DestnRow(x), 1)
      DestnRow(x) = DestnRow(x) + 1
      Limits(x) = Limits(x) - 1
      Exit For
    End If
  Next i
Next rw
End Sub

---

---

p45cal
Really thanks for your help and time! I really I appreciate it!!

i think that your code do what i need.
But i have 2 questions:

How to add to the pasted rows the A column.
And how to add another row that contains options, for example E row, like below:

	A	B	C	D	E
1	some text	3ºoption	1ºoption	2ºoption	4ºoption

Again, thanks for your time and help!!

try:

Code:

---

Sub blah()
Set DestSheets = Sheets(Array("pageB", "pageC", "pageD", "pageE"))
Limits = Array("", 1, 2, 2, 1)
DestnRow = Array("", 6, 6, 6, 6)
For Each rw In Sheets("page1").Range("B1:E5").Rows
  v = Application.Index(rw.Value, 1, 0)
  For k = 1 To UBound(v) 'sort (inefficient!)
    For j = 1 To UBound(v) - 1
      If v(j) > v(j + 1) Then temp = v(j): v(j) = v(j + 1): v(j + 1) = temp
    Next j
  Next k
  For i = 1 To UBound(v)
    x = Application.Match(v(i), rw, 0)
    If Limits(x) > 0 Then
      rw.Offset(, -1).Resize(, rw.Columns.Count + 1).Copy DestSheets(x).Cells(DestnRow(x), 1)
      DestnRow(x) = DestnRow(x) + 1
      Limits(x) = Limits(x) - 1
      Exit For
    End If
  Next i
Next rw
End Sub

---

Are we doing your assignment/homework for you?