Hi
If you to compare different text (upper and lower case) you have to add this code (after Option Explicit and Before Sub RangeColor).
It is to say to add the red-row code
Option Explicit
Option Compare Text
ub RangeColor() Bye, Mario
Posts by Marius44
-
-
Hi
Try with this code (but without Format Condition)Display MoreCode- Option Explicit
- Sub RangeColor()
- Dim sh1 As Worksheet, sh2 As Worksheet
- Dim ur As Long, i As Long, j As Long, k As Long
- Dim startlimit As Variant, proxlimit As Variant, endlimit As Variant
- Dim aa As String, bb As String, cc As String, area_one As String, area_two As String
- Set sh1 = Sheets("control Panel")
- Set sh2 = Sheets("Master File")
- ur = sh2.Cells(Rows.Count, 1).End(xlUp).Row
- With sh1
- startlimit = .Cells(9, 6).Value
- proxlimit = .Cells(12, 6).Value
- endlimit = .Cells(15, 6).Value
- End With
- For i = 2 To ur
- If sh2.Cells(i, 1) = startlimit Then
- aa = "$B$" & i
- For j = i + 1 To ur
- If sh2.Cells(j, 1) = proxlimit Then
- bb = "$L$" & j
- GoTo xit_one
- End If
- Next j
- End If
- Next i
- xit_one:
- area_one = aa & ":" & bb
- For k = 2 To ur
- If sh2.Cells(k, 1) = endlimit Then
- cc = "$B$" & k
- GoTo xit_two
- End If
- Next k
- xit_two:
- area_two = "$B$" & j + 1 & ":$L$" & k
- sh2.Select
- Range("B2:L" & ur).Interior.Color = xlNone
- ' Make yellow background
- Range(area_one).Interior.Color = 13434879
- ' Make green background
- Range(area_two).Interior.Color = 13434828
- Set sh1 = Nothing
- Set sh2 = Nothing
- End Sub
Bye,
Mario -
Hello
Excuse me for my english (I’m Italian)
See if it can go.
First of all, I inserted an OptionButton in each column in row 2 in Sheet1
If you select an Option in cell M2 the column number is written.
Based on the column, a list of Sheet4 was created for a collection with a key and a unique list. Assignment of said list to a data validation for cell M2
Selecting a data item in cell M2 activates the event Worksheet_Change of Sheet1 which executes a Sheet4 filter for the data indicated; then copy all the visible lines in Sheet1
I inserted a Module (Marius) and two buttons in the two sheets.
Let them know. Hello,
Mariohttp://www.filedropper.com/sewingtrimmingmarius
Display MoreCode- Sub ChoiceOption()
- 'by Marius44
- Dim Clct As New Collection
- col = Sheets("Sheet1").Range("M1").Value
- ur = Sheets("Sheet4").Cells(Rows.count, col).End(xlUp).Row
- 'assume i valori di Sheet4 della colonna indicata in M1
- 'e li assegna ad una Collection con chiave
- On Error Resume Next
- For i = 2 To ur
- Clct.Add Sheets("Sheet4").Cells(i, col), CStr(Sheets("Sheet4").Cells(i, col))
- Next i
- On Error GoTo 0
- With Sheets("Sheet1")
- .Range("AA:AA").ClearContents
- For i = 1 To Clct.count
- .Range("AA" & i) = Clct(i)
- Next i
- dati = "$AA$1:$AA$" & Clct.count
- 'assegna la collection ad una convalida dati
- .Range("M2").Select
- With Selection.Validation
- .Delete
- .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
- xlBetween, Formula1:="=" & dati
- End With
- End With
- Application.EnableEvents = False
- Sheets("Sheet1").Range("M2") = ""
- Sheets("Sheet1").Range("A3:M" & ur).ClearContents
- Application.EnableEvents = True
- End Sub
- Sub ShowDetails()
- 'by Marius44
- On Error Resume Next
- Sheets("Sheet4").ShowAllData
- On Error GoTo 0
- End Sub
- Sub ClearSheet1()
- ur = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
- Range("A3:L" & ur).ClearContents
- Sheets("Sheet1").Cells(3, 1).Select
- End Sub
- Private Sub Worksheet_Change(ByVal Target As Range)
- 'by Marius44
- If Not Intersect(Target, Range("M2")) Is Nothing Then
- 'assume i valori di M1 e M2
- col = Sheets("Sheet1").Range("M1").Value
- cod = Sheets("Sheet1").Range("M2").Value
- 'esegue il filtro di Sheet4
- On Error Resume Next
- Sheets("Sheet4").ShowAllData
- On Error GoTo 0
- ur = Sheets("Sheet4").Cells(Rows.count, 1).End(xlUp).Row
- Sheets("Sheet4").Range("$A$2:L" & ur).AutoFilter field:=col, Criteria1:=cod
- 'copia i dati se riga visibile
- a = 2
- Application.ScreenUpdating = False
- For i = 2 To ur
- If Sheets("Sheet4").Rows(i).Hidden = False Then
- With Sheets("Sheet4")
- .Range("A" & i & ":L" & i).Copy
- End With
- a = a + 1
- With Sheets("Sheet1")
- .Cells(a, 1).PasteSpecial
- End With
- End If
- Next i
- Application.ScreenUpdating = True
- Sheets("Sheet1").Cells(3, 1).Select
- End If
- End Sub
-
Hi
I think this code is correctDisplay MoreCode- Sub MatchColumns_Bis()
- 'First List Starts from A10 and ends at J10 (talking about first rows)
- 'Second List starts from L10 and ends W10 (talking about first rows)
- 'would like to paste in Y10.
- Set coll = New Collection
- ur1 = Cells(Rows.Count, 1).End(xlUp).Row
- ur2 = Cells(Rows.Count, 12).End(xlUp).Row
- Range("Y10:AX3000").ClearContents 'changed
- On Error Resume Next
- For i = 10 To ur1 'changed
- coll.Add Cells(i, 1).Value, CStr(Cells(i, 1))
- Next i
- For i = 10 To ur2 'changed
- coll.Add Cells(i, 12).Value, CStr(Cells(i, 12))
- Next i
- On Error GoTo 0
- ReDim ordina(1 To coll.Count)
- For i = 1 To coll.Count
- ordina(i) = coll(i)
- Next i
- For i = 1 To UBound(ordina) - 1
- For j = i + 1 To UBound(ordina)
- If ordina(i) > ordina(j) Then
- temp = ordina(i)
- ordina(i) = ordina(j)
- ordina(j) = temp
- End If
- Next j
- Next i
- a = 9 'changed
- For j = 1 To UBound(ordina)
- flg = 0
- For i = 10 To ur1 'changed
- If ordina(j) = Cells(i, 1) Then
- a = a + 1: flg = 1
- Range(Cells(i, 1), Cells(i, 10)).Copy Cells(a, 25)
- End If
- Next i
- If flg = 0 Then a = a + 1
- Next j
- a = 9 'changed
- For j = 1 To UBound(ordina)
- flg = 0
- For i = 10 To ur2 'changed
- If ordina(j) = Cells(i, 12) Then
- a = a + 1: flg = 1
- Range(Cells(i, 12), Cells(i, 23)).Copy Cells(a, 36)
- End If
- Next i
- If flg = 0 Then a = a + 1
- Next j
- End Sub
I have marked what I have changed.
Try again but you could known that I have no tested it.
Bye,
Mario -
Hi
Will you be so kind to tell me the first and the last cell of every list and the cell where you want to paste the new lists?
This is necessary to adjust the code. Tanks and bye,
Mario -
Hi
Excuse me for my english (i'm italian)
Try with this codeDisplay MoreCode- Sub MatchColumns()
- Set coll = New Collection
- ur1 = Cells(Rows.Count, 1).End(xlUp).Row
- ur2 = Cells(Rows.Count, 5).End(xlUp).Row
- Range("J2:P100").ClearContents
- On Error Resume Next
- For i = 2 To ur1
- coll.Add Cells(i, 1).Value, CStr(Cells(i, 1))
- Next i
- For i = 2 To ur2
- coll.Add Cells(i, 5).Value, CStr(Cells(i, 5))
- Next i
- On Error GoTo 0
- ReDim ordina(1 To coll.Count)
- For i = 1 To coll.Count
- ordina(i) = coll(i)
- Next i
- For i = 1 To UBound(ordina) - 1
- For j = i + 1 To UBound(ordina)
- If ordina(i) > ordina(j) Then
- temp = ordina(i)
- ordina(i) = ordina(j)
- ordina(j) = temp
- End If
- Next j
- Next i
- a = 1
- For j = 1 To UBound(ordina)
- flg = 0
- For i = 2 To ur1
- If ordina(j) = Cells(i, 1) Then
- a = a + 1: flg = 1
- Range(Cells(i, 1), Cells(i, 3)).Copy Cells(a, 10)
- End If
- Next i
- If flg = 0 Then a = a + 1
- Next j
- a = 1
- For j = 1 To UBound(ordina)
- flg = 0
- For i = 2 To ur2
- If ordina(j) = Cells(i, 5) Then
- a = a + 1: flg = 1
- Range(Cells(i, 5), Cells(i, 7)).Copy Cells(a, 14)
- End If
- Next i
- If flg = 0 Then a = a + 1
- Next j
- End Sub
Bye,
Mario -
Hello
Try with this codeDisplay MoreCode- Option Explicit
- Private Sub UserForm_Initialize()
- 'ListBox1.RowSource = Sheets("Sheet1").Range("A2:C4").Address
- Dim lastrow As Long, i As Long, x As Long
- lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
- For i = 2 To lastrow
- If ActiveSheet.Cells(i, 2) > 0 Then
- ListBox1.AddItem ActiveSheet.Cells(i, 1)
- x = ListBox1.ListCount - 1
- ListBox1.List(x, 1) = ActiveSheet.Cells(i, 2)
- End If
- Next
Bye,
Mario -
Hello
I suggest you read at this address 'https://www.extendoffice.com/documents/excel/3842-excel-restrict-paste-values-only.html#a2 Bye, Mario -
Hi
I think it would be better "see" the file.
But you just paste the "values" so not a serial number (and this could create problems)Bye,
Mario -
Hi
I think you have to change the code of TextBox2 in this wayPrivate Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 48 To 59
' Allow digits - do nothing
Case 46
' Allow only one dot symbol
If InStr(ActiveControl, ".") Then KeyAscii = 44
Case Else
' Block others
KeyAscii = 0
End Select
End SubIt's to say changing the point
Bye,
Mario -
Hello
Why have you entered the name of the Sheets?
If you have defined Names just type them in square brackets.
In my macro there are no names of the sheets and it worked.bye,
Mario -
-
Thanks for the welcome feedback.
I'm counting for you.
Hi,
Mario -
Hello AshaG
Excuse me, first of all, my English (I'm Italian)
If I understood the question correctly, this is the macro that, I suppose, solves the problem.
One thing I did not understand is how it does (with which criteria) the value of column ID-2 changes.Display MoreCode- Sub prova()
- ur1 = Cells(Rows.Count, 1).End(xlUp).Row
- ur2 = Cells(Rows.Count, 4).End(xlUp).Row
- ReDim listcod(3 To ur1 + ur2)
- For i = 3 To ur1
- listcod(i) = Cells(i, 1)
- Next i
- For i = 3 To ur2
- listcod(i + ur1 - 2) = Cells(i, 4)
- Next i
- For i = 3 To UBound(listcod)
- Cells(i, 11) = listcod(i)
- Next i
- ActiveSheet.Range("$K$3:$K$" & UBound(listcod)).RemoveDuplicates Columns:=1, Header:=xlNo
- ActiveSheet.Range("$K$3:$K$" & UBound(listcod)).Sort Key1:=Range("$K$3"), Order1:=xlAscending, Header:=xlGuess, _
- OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
- ur3 = Cells(Rows.Count, 11).End(xlUp).Row
- ReDim listcod(3 To ur3)
- a = 2
- For i = 3 To UBound(listcod)
- If Cells(i, 11) <> "" Then
- listcod(i) = Cells(i, 11).Value
- End If
- Next i
- ActiveSheet.Range("$K$3:$K$" & UBound(listcod)).ClearContents
- ReDim List1(3 To ur1, 1 To 3)
- ReDim List2(3 To ur2, 1 To 6)
- For i = 3 To ur1
- For j = 1 To 3
- List1(i, j) = Cells(i, j).Value
- Next j
- Next i
- For i = 3 To ur2
- For j = 1 To 6
- List2(i, j) = Cells(i, j + 3).Value
- Next j
- Next i
- For i = 3 To UBound(listcod)
- For j = 3 To ur1
- If listcod(i) = List1(j, 1) Then
- For k = 1 To 3
- Cells(i, k + 10) = List1(j, k)
- Next k
- Exit For
- Else
- End If
- Next j
- For j = 3 To ur2
- If listcod(i) = List2(j, 1) Then
- For k = 1 To 6
- Cells(i, k + 13) = List2(j, k)
- Next k
- Exit For
- Else
- End If
- Next j
- Next i
- End Sub
Let me know.
Hi, Mario -
Hi
of course you're right. Hello, Mario -
-
Sorry, you're right.
Maybe it's a bug VBABye,bye
Mario -
-
Hi Marko
I'm glad to have been helpful.
Thank you for your courteous deferment.
Best wishes for the next holidays.Bye,
Mario -
Hi Marko
I don't know.
I upload my file that works correctly.
I have added Option Explicit and variables declaretions.Ciao,
Mario