Posts by dangle

dangle · Apr 23rd 2012

Re: A Macro For Various Data Corrections From List

I hope the optimism is justified!

Give this a try:

Code

Dim a, i As Long, rCell As Range, ws As Worksheet
a = Sheets("List Sheet").Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .comparemode = 1
    For i = 2 To UBound(a, 1)
        If Not .exists(Trim(a(i, 1))) Then .Item(Trim(a(i, 1))) = Trim(a(i, 2))
    Next
    For Each ws In Worksheets
        If ws.Name <> "List Sheet" Then
            For Each rCell In ws.Columns("I").SpecialCells(2, 2)
                If .exists(Trim(rCell.Value)) Then rCell.Offset(, 4) = .Item(rCell.Value)
            Next
        End If
    Next
End With
Set rCell = Nothing
Set ws = Nothing
End Sub

Display More

dangle · Apr 23rd 2012

Re: Looping copy/paste help. Copying from column 1 to a spreadsheet

Hi Evan and welcome to the forum

If you are adding code to the post you should wrap it in code tags to make it easier to read. You can edit your post to sort this.

Looking at your macro, you haven't set your variables. What are the values of "i", "Rownum" and "Colnum".

This might help as an alternative, if I've understood your requirements correctly. You can change the range and number of times it repeats to suit.

Code

Sub Evan1()
Dim i As Long
Dim r As Range
Set r = Range("A1:A20") 'Change the range to suit
For i = 0 To 15 'Change 15 to set the number of repeats
    r.Offset(i * r.Rows.Count, i + 1).Value = r.Offset(i * r.Rows.Count).Value
Next
Set r = Nothing
End Sub

dangle · Apr 23rd 2012

Re: Copy Matching Values Rows To New Sheet

Hi Claire and welcome to the forum.

Please could you upload a sample of your data to make it easier to provide a solution.

dangle · Apr 23rd 2012

Re: copy data from a set column in a workbook to rows in a different workbook

Assuming the file is open, then:

Code

Sub Copier2()
Dim i As Long
With Rows("4:6")
    For i = 0 To 249
        .Offset(i * 3).Copy Workbooks("Workbook2").Sheets("Sheet1").Rows("30:32").Offset(i * 38)
    Next
End With
        
End Sub

dangle · Apr 21st 2012

Re: Macro for iteratively updating a grid based on inputs

I don't understand how the date fits into your logic.

This will give the output you require but maybe not for the right reasons.

Add code to a standard module in Workbook2. Workbook1 saved as Workbook1.xls. Both files should be in the same folder. If it's not right, please provide more info.

Code

Sub Updater()
Dim a, i As Long, rCell As Range
With Workbooks.Open(ThisWorkbook.Path & "\Workbook1.xls")
    With Sheets("Sheet1")
        a = .UsedRange.Value
    End With
    .Close False
End With
With Sheets("Sheet1")
    For Each rCell In .Columns(1).SpecialCells(2, 2)
        For i = 2 To UBound(a, 1)
            If rCell = a(i, 1) Then
                a(i, 2) = a(i, 2) + rCell.Offset(, 1)
            End If
        Next
    Next
    .Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
End With
Set rCell = Nothing
End Sub

Display More

dangle · Apr 21st 2012

Re: Compare Multiple Coloumns

Desi

I am not quite sure what you are doing since it looks like you could use a simple if formula, but if you want to read the values you could use a variant like:

Code

Sub CompareValues()
Dim a, i As Long
a = Range("A1").CurrentRegion
For i = 1 To UBound(a, 1)
    'Do something
Next
End Sub

Perhaps you could explain more and provide a sample workbook showing what you are trying to achieve.

dangle · Apr 21st 2012

Re: A Macro For Various Data Corrections From List

Hi Bob

This should be possible but please upload a small sample workbook to make it easier to provide a solution.

dangle · Apr 20th 2012

Re: copy data from a set column in a workbook to rows in a different workbook

Hi arm

Does this help?

Code

Sub Copier()
Dim i As Long
With Rows("4:6")
    For i = 0 To 249
        .Offset(i * 3).Copy Sheet2.Rows("30:32").Offset(i * 38)
    Next
End With
        
End Sub

dangle · Apr 19th 2012

Re: vba code to copy down a column & paste in row

OK. I think this is what you are after:

Code

Sub Macro2()
Dim a, b(), i As Long, ii As Long, rCount As Long, x As Long, y As Long
Const nRows = 64
rCount = Round(WorksheetFunction.CountA(Columns(1)) / nRows)
ReDim b(1 To 1, 1 To nRows * rCount * 2)
For y = 0 To rCount - 1
    a = Range("A3").Offset((nRows + 3) * y).Resize(nRows, 2).Value
    For i = 1 To UBound(a, 1)
        For ii = 1 To UBound(a, 2)
            x = x + 1
            b(1, x) = a(i, ii)
        Next
    Next
Next
Range("A1:B1").AutoFill Range("A1").Resize(, UBound(b, 2) + UBound(a, 2)), xlFillCopy
Range("A1").Offset(1, UBound(a, 2)).Resize(1, UBound(b, 2)).Value = b
End Sub

Display More

dangle · Apr 18th 2012

Re: Use VBA to open a file with a date in the filename

Could you perhaps use the DateCreated property of the FileSystemObject, assuming that the filenames correspond with the creation date?

For example:

Code

Sub OpenLastFile()
Dim fName As String, fOpen As String, d1
ChDir ("C:\userdata\files\")
fName = Dir("")
d1 = 0
Do Until fName = ""
    With CreateObject("Scripting.FileSystemObject").Getfile(fName)
        If .datecreated > d1 Then
            d1 = .datecreated
            fOpen = fName
        End If
    End With
    fName = Dir
Loop
Workbooks.Open fOpen
End Sub

Display More

dangle · Apr 18th 2012

Re: Use VBA to open a file with a date in the filename

Hi Joe

Are the dates in the filenames in US format?

dangle · Apr 18th 2012

Re: Multiple Rows to Single Column

Nitin - welcome to the forum.

This outputs to a new sheet.

Assuming data starts in A1, try:

Code

Option Base 1
Sub Flipper()
Dim a, b(), i As Long, ii As Long, x As Long, wS As Worksheet
a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim b(1, 1 To UBound(a, 1) * UBound(a, 2))
For i = 1 To UBound(a, 1)
    For ii = 1 To UBound(a, 2)
        x = x + 1
        b(1, x) = a(i, ii)
    Next
Next
Set wS = Worksheets.Add
wS.Range("A1").Resize(1, UBound(b, 2)).Value = b
Set wS = Nothing
End Sub

Display More

dangle · Apr 18th 2012

Re: Compare Range from different workbooks and if range match copy and paste.

Hi Jacwe

Book1 and Book2 need to be in the same folder. Book2 saved as Book2.xls
Then add the code to a standard module in Book1 and run.

Code

Sub Matcher()
Dim a, b, i As Long, lRow As Long
With Workbooks.Open(ThisWorkbook.Path & "\Book2.xls")
    With Sheets("Sheet1")
        a = .UsedRange.Value
    End With
    .Close False
End With
With Sheets("Sheet1")
    lRow = .Range("B" & Rows.Count).End(xlUp).Row
    b = .Range("B2:D" & lRow).Value
End With
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a, 1)
        If Not .exists(a(i, 1)) Then
            .Item(a(i, 1)) = a(i, 3)
        End If
    Next
    For i = 1 To UBound(b, 1)
        If .exists(b(i, 1)) Then
            b(i, 3) = .Item(b(i, 1))
        End If
    Next
    Sheets("Sheet1").Range("B2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End With
End Sub

Display More

dangle · Apr 18th 2012

Re: if statement with value between two other values

For VB:

Code

If x < 5 And x > -5 Then

dangle · Apr 18th 2012

Re: vba code to copy down a column & paste in row

Hi Lior and welcome to the forum.
Without seeing a sample workbook, this is my guess.
It will loop through all the worksheets and do the transpose.
If it's not what you're after then please give more info and provide a sample workbook.

Code

Option Base 1
Sub Flipper()
Dim a, b(), i As Long, ii As Long, x As Long, wS As Worksheet
For Each wS In Worksheets
    With wS.UsedRange
        a = .Value
        ReDim b(1, 1 To UBound(a, 1) * UBound(a, 2))
        For i = 1 To UBound(a, 1)
            For ii = 1 To UBound(a, 2)
                x = x + 1
                b(1, x) = a(i, ii)
            Next
        Next
        .Offset(, UBound(a, 2)).Resize(1, UBound(b, 2)).Value = b
    End With
    x = 0
Next
Set wS = Nothing
end Sub

Display More

dangle · Apr 13th 2012

Re: Macro Find Only Consecutive Duplicates in a Column

Sorry, strictly speaking it is not onto a 'new' sheet so just be careful if you have data on the 'codenamed' Sheet2. I can adjust if necessary.

dangle · Apr 13th 2012

Re: Macro Find Only Consecutive Duplicates in a Column

J

This outputs onto a new sheet. Give it a try and let me know if there are any issues:

Code

Sub DubDups()
Dim a, i As Long
a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
For i = 1 To UBound(a, 1) - 1
    If a(i, 1) <> vbNullString Then
        If a(i, 1) = a(i + 1, 1) And a(i, 2) = a(i + 1, 2) Then
            a(i, 3) = "YES"
            a(i + 1, 3) = "YES"
        End If
    End If
Next
Sheet2.Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

Display More

dangle · Apr 11th 2012

Re: Find keyword and add an item

Hi Panwar

I am not sure if you wanted to look for multiple occurences or not so I have allowed for this.

Try:

Code

Sub FindSpoons()
Dim r As Range, s As String
Set r = Cells.Find("Spoons", , , , , , False)
s = r.Address
If Not r Is Nothing Then
    r(2).EntireRow.Insert (-4121)
    r.Resize(2) = [{"Kitchen";"Spoons"}]
    Do
        Set r = Cells.FindNext(r(2))
        If r.Offset(-1).Address = s Then Exit Do
        r(2).EntireRow.Insert (-4121)
        r.Resize(2) = [{"Kitchen";"Spoons"}]
    Loop
End If
Set r = Nothing
End Sub

Display More

dangle · Apr 6th 2012

Re: Copy and overwright rows between workbooks based on a match in a single column

One quick thought though. Check the worksheet name in the 'With workbooks' line:

Change:

Code

With Workbooks("Spreadsheet B").Sheets(1).Range("A3").CurrentRegion.Resize(, ColCount)

to:

Code

With Workbooks("Spreadsheet B").Sheets("Sheet1").Range("A3").CurrentRegion.Resize(, ColCount)

But enter the correct sheet name from Workbook(Spreadsheet B) if it is not 'Sheet1'. I think this may be your issue but will have a further look if not.

dangle · Apr 6th 2012

Re: Copy and overwright rows between workbooks based on a match in a single column

DC

I am heading out now and probably not around for at least 24 hours so won't be able to get back to you. Maybe someone else can pick up if it's urgent, else I will have another look and try to help when I'm back.

Best of luck!