Hello
I did not understand anything.
And then why attach a VBA protected file?
Hello,
Mario
Hello
I did not understand anything.
And then why attach a VBA protected file?
Hello,
Mario
Hello
With VBA? Try this macro
Sub CountNonZero()
ur = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To ur
trg = Sheets("Sheet1").Cells(i, 1).Value
For j = 3 To ur
cnt = Sheets("Sheet2").Cells(j, 1).Value
If trg = cnt Then
Rng = "B" & j & ":P" & j
nn = Application.WorksheetFunction.CountIfs(Sheets("Sheet2").Range(Rng), ">0")
Sheets("Sheet1").Cells(i, 4) = nn
nn = 0
Exit For
End If
Next j
Next i
End Sub
Display More
Let me know. Hello,
Mario
Hello
Try in B2 and drag down
=COUNTIFS(Sheet2!B3:P3;">0")
Hello,
Mario
Hello
I followed the example given by the applicant.
Hello,
Mario
Hello
If I understand correctly I believe that the use of VBA is necessary.
A double loop to scan the cells of the first table and a counter to increment the target column.
Hello,
Mario
Hi
You have to adapt the formulas like these:
in E11 =SE(C11="";"";SE.ERRORE($F$2*(C11-$I$2);"" )) and copy to E19
in E23 =SE(C23="";"";SE.ERRORE($F$3*(C23-$I$3);"" )) and copy to E27
in E31 =SE(C31="";"";SE.ERRORE($F$4*(C31-$I$4);"" )) and copy to E45
Hi,
Mario
Hello
Try this
=IF(C17>0;$F$2*(C17-$I$2);"")
Hi,
Mario
Really so I did put in the code and test it out.. when I save it then close it out. I open it up just now. why is it not there anymore I don't get it as it suppose to stay in there. so what am I doing wrong here?
Hello
After entering the code how do you save the file? With what extension?
If the extension is different from .xlsm it warns you but does NOT save the code.
I hope I didn't say nonsense.
Hello,
Mario
Hello
Instead of using TRUE / FALSE use this formula for column F (the one I used) = IF (B3 <= 0.05, B3, 0).
In G3 put this formula = MAX (F3: F59)
Finally in FC enter and this formula (choosing the color you like best) = B3 = $ G $ 3 and in It applies to this reference = $ B $ 3: $ B $ 59
Hello,
Mario
Hello
Could you please attach your file (without sensitive data) with the problem.
Thanks in advance. Hello,
Mario
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
Hi
Try with this code (but without Format Condition)
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
Display More
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,
Mario
http://www.filedropper.com/sewingtrimmingmarius
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
Display More
Hi
I think this code is correct
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
Display More
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 code
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
Display More
Bye,
Mario
Hello
Try with this code
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
Display More
Bye,
Mario