Re: Random Text for List Based on Sum Criteria
No problem. Glad to be of some help.
Please note that on 14th December 2023 users will experience an expected outage whilst we make upgrades to our network. We anticipate this process may take a couple of hours and so we apologise in advance for any inconvenience.
Re: Random Text for List Based on Sum Criteria
No problem. Glad to be of some help.
Re: Copy row, insert twice and change cell in each row to different value - insert is
Like Patel, I am not entirely sure what you are after but using 'ActiceCell' and 'Select' is probably not the way to go with this. It is likely to lead to strange results:
Give this a try:
Sub InsertRows()
Dim i As Long
For i = Range("J" & Rows.Count).End(xlUp).Row To 2 Step -1
If Trim(Cells(i, 10)) = "5 Pocket" Then
Rows(i).Copy
Rows(i).Resize(2).Insert
Cells(i, 14).Resize(3) = Application.Transpose(Array("Back double welt pocket", _
"Front single welt pocket", "Front double welt pocket"))
End If
Next
Application.CutCopyMode = False
End Sub
Display More
Re: Random Text for List Based on Sum Criteria
Hi Zach
This will pick one of the values randonmly and sum until the total is within the range. I guess there could be an argument on whether it is truly random but it might work for your purposes. Your data should start in cell "A1".
Sub RandomPicker()
Dim a, iVal, totVal, nextVal, i As Long, sCombo As String
a = Range("a1").CurrentRegion.Value
ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
Do
Randomize
iVal = Int((UBound(a, 1) * Rnd + 1))
nextVal = a(iVal, 2)
If nextVal + totVal < 601 Then
totVal = totVal + nextVal
a(iVal, 3) = a(iVal, 3) + 1
End If
Loop Until totVal > 449 And totVal < 601
For i = 1 To UBound(a, 1)
If a(i, 3) = 1 Then
sCombo = IIf(sCombo = vbNullString, a(i, 1), _
sCombo & " + " & a(i, 1))
ElseIf a(i, 3) <> vbNullString Then
sCombo = IIf(sCombo = vbNullString, a(i, 3) & a(i, 1), _
sCombo & " + " & a(i, 3) & a(i, 1))
End If
Next
Range("d1") = sCombo
End Sub
Display More
Re: Leveling Macro
Hi scambug
Give this is a try. If there are more levels of children it may need adjusting:
Sub Transposer()
Dim a, b(), i As Long, x As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 1) > 1 Then
x = x + 1
b(x, 1) = IIf(a(i, 1) = 2, Left(a(i, 2), 1), Left(a(i, 2), 2))
b(x, 2) = a(i, 2)
End If
Next
Range("C1").Resize(x, UBound(b, 2)).Value = b
End Sub
Display More
Re: Compare 2 Excel Sheets Line by Line and Highlight all new data on a new sheet
excelhelp2
Yes it is possible but I recommend you use jindon's code since I'm not going to be able to improve on that.
Re: Compare 2 Excel Sheets Line by Line and Highlight all new data on a new sheet
If I have understood correctly, this should highlight anything removed in blue and anything added in red. Give it some testing.
Sub CompareData()
Dim a, aRR(), i As Long, j As Long, sTr As String
Dim r As Range, wS As Worksheet
Dim sDic1 As Object, sDic2 As Object
Set sDic1 = CreateObject("Scripting.Dictionary")
Set sDic2 = CreateObject("Scripting.Dictionary")
Sheets("Sheet2").Copy After:=Sheets(Sheets.Count)
Set wS = ActiveSheet
wS.Name = "Comparison"
a = Sheets("Sheet2").Range("a1").CurrentRegion.Value
ReDim aRR(1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
aRR(j) = a(i, j)
Next
sTr = Join$(aRR, "-")
sDic1.Item(sTr) = Empty
Next
With Sheets("Sheet1")
For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row
For j = 1 To .Cells(1, 1).End(xlToRight).Column
aRR(j) = Trim(.Cells(i, j))
Next
sTr = Join$(aRR, "-")
If Not sDic1.exists(sTr) Then
If r Is Nothing Then
Set r = .Range(.Cells(i, 1), .Cells(i, 10))
Else
Set r = Union(r, .Range(.Cells(i, 1), .Cells(i, 10)))
End If
End If
Next
End With
With r.Font
.Color = vbBlue
.Bold = True
End With
r.Copy wS.Range("a" & Rows.Count).End(xlUp).Offset(1)
Set r = Nothing
a = Sheets("Sheet1").Range("a1").CurrentRegion.Value
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
aRR(j) = a(i, j)
Next
sTr = Join$(aRR, "-")
sDic2.Item(sTr) = Empty
Next
With wS
For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row
For j = 1 To .Cells(1, 1).End(xlToRight).Column
aRR(j) = Trim(.Cells(i, j))
Next
sTr = Join$(aRR, "-")
If Not sDic2.exists(sTr) Then
If r Is Nothing Then
Set r = .Range(.Cells(i, 1), .Cells(i, 10))
Else
Set r = Union(r, .Range(.Cells(i, 1), .Cells(i, 10)))
End If
End If
Next
End With
With r.Font
.Color = vbRed
.Bold = True
End With
Set r = Nothing
Set sDic1 = Nothing
Set sDic2 = Nothing
Set wS = Nothing
End Sub
Display More
Re: Combine multiple records onto 1 row based on unique name/surname in the first col
Hi Anita
In case you haven't resolved this yet. The data should start in A1.
Sub Consolidate()
Dim a, i As Long
Const NumEntries As Long = 20 '<<Change this to allow more column entries if required
a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, NumEntries).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
.Item(a(i, 1)) = .Count + 1
a(.Count, 1) = a(i, 1)
a(.Count, 2) = a(i, 2)
a(.Count, NumEntries) = 1
Else
a(.Item(a(i, 1)), NumEntries) = a(.Item(a(i, 1)), NumEntries) + 1
a(.Item(a(i, 1)), (a(.Item(a(i, 1)), NumEntries) + 1)) = a(i, 2)
End If
Next
Sheets("Sheet2").Range("A1").Resize(.Count, UBound(a, 2) - 1).Value = a
End With
End Sub
Display More
Re: Move multiple columns to multiple rows
No problem. Glad it's working for you.
Re: Numeric wildcard
A beast but very well thought through.
A possible, as a UDF:
Re: Move multiple columns to multiple rows
This will test to see if you have the correct number of columns for each set of names.
Sub Xpander3()
Dim a, b(), i As Long, j As Long, k As Long, x As Long
Const RepeatCols As Long = 17 'change this to set the last repeating column
Const NameCols As Long = 7 'change this to set the number of columns for each name
a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
If ((UBound(a, 2) - RepeatCols) Mod NameCols) <> 0 Then
MsgBox "Incorrect number of columns. Over and out."
Exit Sub
End If
ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - RepeatCols) / NameCols, 1 To RepeatCols + NameCols)
For i = 1 To UBound(a, 1)
For j = RepeatCols + 1 To UBound(a, 2) Step NameCols
If a(i, j) <> vbNullString Then
x = x + 1
For k = 1 To RepeatCols
b(x, k) = a(i, k)
Next
For k = 1 To NameCols
b(x, RepeatCols + k) = a(i, j + k - 1)
Next
End If
Next
Next
Sheets("Sheet2").Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Display More
Re: Move multiple columns to multiple rows
You had two extra columns in the last sample you sent me. Did you delete those?
Re: Runtime error 424
Have you created controls for 'num_form_ok' and 'num_form_cancel'? I think this may be the likely cause.
Re: Reconciling A Master Worksheet Against Three Other Worksheets
It's hard to fully appreciate this without seeing an example. Why can't you upload something, even a mock-up of the data?
Re: Move multiple columns to multiple rows
OK. This one you can change to suit the number of household columns and the number of columns per person. Seems to work on what you gave me once I deleted the last two columns but let me know.
Sub XPander2()
Dim a, b(), i As Long, j As Long, k As Long, x As Long
Const RepeatCols As Long = 17 'change this to set the last repeating column
Const NameCols As Long = 7 'change this to set the number of columns for each name
a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - RepeatCols) / NameCols, 1 To RepeatCols + NameCols)
For i = 1 To UBound(a, 1)
For j = RepeatCols + 1 To UBound(a, 2) Step NameCols
If a(i, j) <> vbNullString Then
x = x + 1
For k = 1 To RepeatCols
b(x, k) = a(i, k)
Next
For k = 1 To NameCols
b(x, RepeatCols + k) = a(i, j + k - 1)
Next
End If
Next
Next
Sheets("Sheet2").Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Display More
Re: Move multiple columns to multiple rows
What about column R? What is the pattern for each name to be transposed, or how many columns for each name should be transposed?
Re: Move multiple columns to multiple rows
It should work for additional columns as it is. Give it a try and let me know. The only thing to change would be if you have more than ten names to transpose. In which case change:
to:
Re: Compare data set 1 with data set 2. Add to data set 2 if not found
No problem. Glad it saved you some time and thanks for your comments. Let me know if I can help to explain.
Re: Compare data set 1 with data set 2. Add to data set 2 if not found
Omar
It is always best to upload a sample of data so that we can clearly understand your requirements. This may help but you will need to test it yourself as I am not creating a workbook for you.
Sub CompareDs()
Dim a(), r As Range, x As Long
Dim sDic As Object
Set sDic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
For Each r In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
sDic.Item(r & "|" & r.Offset(, 1)) = Empty
Next
End With
With Sheets("Sheet1")
ReDim a(1 To sDic.Count + .Range("A" & Rows.Count).End(xlUp).Row, 1 To 2)
For Each r In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
If Not sDic.exists(r & "|" & r.Offset(, 1)) Then
x = x + 1
a(x, 1) = r
a(x, 2) = r.Offset(, 1)
End If
Next
End With
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
Set sDic = Nothing
End Sub
Display More
Re: Move multiple columns to multiple rows
I am not sure about a formula but a possible marco:
Sub XPander()
Dim a, b(), i As Long, j As Long, k As Long, x As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * 10, 1 To 6)
For i = 1 To UBound(a, 1)
For j = 5 To UBound(a, 2) Step 2
If a(i, j) <> vbNullString Then
x = x + 1
For k = 1 To 4
b(x, k) = a(i, k)
Next
b(x, 5) = a(i, j)
b(x, 6) = a(i, j + 1)
End If
Next
Next
Sheets("Sheet2").Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Display More
Re: Compare 2 workbook using Scripting.dictionary(Whats wrong in my code?)
Can you provide the data that this code is running on? Where is it failing?