Posts by Marius44

Marius44 · May 31st 2022

Hello

I did not understand anything.

And then why attach a VBA protected file?

Hello,

Mario

Marius44 · May 17th 2022

Hello

With VBA? Try this macro

Code

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

Marius44 · May 17th 2022

Hello

Try in B2 and drag down

=COUNTIFS(Sheet2!B3:P3;">0")

Hello,

Mario

Marius44 · Apr 28th 2022

Hello

I followed the example given by the applicant.

Hello,

Mario

Marius44 · Apr 28th 2022

Hello

Try this macro

Code

Sub prova()
If ((IsEmpty(Range("O20")) Or Not IsNumeric(Range("O20"))) And IsNumeric(Range("Q20"))) Or _
(IsNumeric(Range("O20")) And (IsEmpty("Q20") Or Not IsNumeric(Range("Q20")))) Then
GoTo ErrorHandle
End If
'run code
End Sub

Hi,

Mario

Marius44 · Apr 27th 2022

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

Marius44 · Apr 23rd 2022

Hello

I think you need to replace this line of code

Code

Worksheets("Raw Data").Rows(i).Copy

with this one

Code

Worksheets("Raw Data").Range("A" & i & ":L" & i).Copy

Let them know. Hello,

Mario

Marius44 · Mar 21st 2022

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

Marius44 · Mar 21st 2022

Hello

Try this

=IF(C17>0;$F$2*(C17-$I$2);"")

Hi,

Mario

Marius44 · Mar 19th 2022

Quote from Desert Rats

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

Marius44 · Mar 17th 2022

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

Marius44 · Mar 12th 2022

Hello

I think is better to change your code on CommandButton1 like this

Code

Private Sub CommandButton1_Click()
    For i = lstProducts.ListCount - 1 To 0 Step -1
        lstProducts.List(i, 1) = lstProducts.List(i, 1) + 1
    Next i
    
End Sub

Hope it helps. Hello,

Mario

Marius44 · Mar 11th 2022

Hello

Could you please attach your file (without sensitive data) with the problem.

Thanks in advance. Hello,

Mario

Marius44 · Jul 20th 2019

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

Marius44 · Jul 20th 2019

Hi
Try with this code (but without Format Condition)

Code

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

Marius44 · Jul 19th 2019

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

Code

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

Marius44 · Jul 17th 2019

Hi
I think this code is correct

Code

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

Marius44 · Jul 17th 2019

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

Marius44 · Jul 17th 2019

Hi
Excuse me for my english (i'm italian)
Try with this code

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

Marius44 · Apr 18th 2019

Hello
Try with this code

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

Posts by Marius44

VBA-Daily Average Vol

Identify Row Number on Different Sheet to complete COUNTIF on (in single formula)

Identify Row Number on Different Sheet to complete COUNTIF on (in single formula)

Empty cell true or false

Empty cell true or false

Transferring Data from one sized grid to another sized destination

Need to copy only part of a row if conditions are met and paste into new worksheet.

Help with formula

Help with formula

Macro button disappearing

Conditional formatting with 2 criteria of 2 columns.

VBA Userform Scrollable Listbox displaying incorrect value

Chart axis values are different sizes within the same label

Conditional Format when Criteria is Met

Conditional Format when Criteria is Met

Search And Display Filtering

comparing two columns in excel, inserting blank rows moving associated data

comparing two columns in excel, inserting blank rows moving associated data

comparing two columns in excel, inserting blank rows moving associated data

ListBox for Specific Condition