Posts by dangle

dangle · Nov 10th 2012

Re: Random Text for List Based on Sum Criteria

No problem. Glad to be of some help.

dangle · Nov 10th 2012

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:

Code

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

dangle · Nov 10th 2012

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".

Code

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

dangle · Nov 9th 2012

Re: Leveling Macro

Hi scambug

Give this is a try. If there are more levels of children it may need adjusting:

Code

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

dangle · Sep 25th 2012

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.

dangle · Sep 20th 2012

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.

Code

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

dangle · Sep 12th 2012

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.

Code

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

dangle · Jul 26th 2012

Re: Move multiple columns to multiple rows

No problem. Glad it's working for you.

dangle · Jul 26th 2012

Re: Numeric wildcard

A beast but very well thought through.

A possible, as a UDF:

Code

Function FindNumberedCells(searchRange As Range) As Long
Dim rCell As Range, x As Long
With CreateObject("VBScript.RegExp")
    .Global = False
    .Pattern = "\d"
    For Each rCell In searchRange
        If .test(rCell.value) Then
            x = x + 1
        End If
    Next
End With
FindNumberedCells = x
End Function

Display More

dangle · Jul 26th 2012

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.

Code

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

dangle · Jul 26th 2012

Re: Move multiple columns to multiple rows

You had two extra columns in the last sample you sent me. Did you delete those?

dangle · Jul 24th 2012

Re: Runtime error 424

Have you created controls for 'num_form_ok' and 'num_form_cancel'? I think this may be the likely cause.

dangle · Jul 23rd 2012

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?

dangle · Jul 23rd 2012

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.

Code

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

dangle · Jul 23rd 2012

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?

dangle · Jul 23rd 2012

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:

Code

ReDim b(1 To UBound(a, 1) * 10, 1 To 6)

to:

Code

ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - 4) / 2, 1 To 6)

dangle · Jul 21st 2012

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.

dangle · Jul 21st 2012

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.

Code

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

dangle · Jul 21st 2012

Re: Move multiple columns to multiple rows

I am not sure about a formula but a possible marco:

Code

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

dangle · Jul 21st 2012

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?

Posts by dangle

Random Text for List Based on Sum Criteria

Copy row, insert twice and change cell in each row to different value - insert issue

Random Text for List Based on Sum Criteria

[SOLVED]Leveling Macro

Compare 2 Excel Sheets Line by Line and Highlight all new data on a new sheet

Compare 2 Excel Sheets Line by Line and Highlight all new data on a new sheet

Combine multiple records onto 1 row based on unique name/surname in the first column

Move multiple columns to multiple rows

Numeric wildcard

Move multiple columns to multiple rows

Move multiple columns to multiple rows

Runtime error 424

Reconciling A Master Worksheet Against Three Other Worksheets

Move multiple columns to multiple rows

Move multiple columns to multiple rows

Move multiple columns to multiple rows

Compare data set 1 with data set 2. Add to data set 2 if not found

Compare data set 1 with data set 2. Add to data set 2 if not found

Move multiple columns to multiple rows

Compare 2 workbook using Scripting.dictionary(Whats wrong in my code?)