PDA

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



lautaroml
05-11-2014, 03:44 PM
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:


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

patel
05-11-2014, 10:32 PM
can you attach a sample file with data and desired result ?

HaHoBe
05-12-2014, 02:37 AM
Hi, lautaroml,

maybe have a try with this 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

p45cal
05-12-2014, 03:24 AM
…or this one
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

HaHoBe
05-12-2014, 03:26 AM
Hi, lautaroml,

an update of the code tryaing to satisfy the restraints:

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

lautaroml
05-12-2014, 12:25 PM
Sure, here it is:

11675


Thanks for your time and help!!

lautaroml
05-12-2014, 12:47 PM
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!

lautaroml
05-12-2014, 01:01 PM
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!!

lautaroml
05-12-2014, 02:02 PM
…or this one
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!!

p45cal
05-20-2014, 04:35 AM
try:
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?