VBA need help here!

NewToVBAs · Apr 2, 2011

Hi MrExcel

my program doesnt seems to be working =(

here is what i need to do:
1) read off the raw data file (filename: RawData.xls)
2) produce the Date as the first column, and the prices of the 5 goods in respective subsequent columns
3) omit all the prices for a date if price info is missing for any of the 5 goods

my RawData file looks like this: 2 columns of Date and Good1Price, followed by 1 empty column, then 2 columns of Date and Good2Price, followed by 1 empty column, etc...

Date Good1Price Date Good2Price Date Good3Price Date Good4Price Date Good5Price

this is my program code:

Sub CopyData()
'copy dates from raw data to project file
'Workbooks.Open Filename:="C:\Users\User\Desktop\RawData.xls"
Dim MyInput As String
MyInput = InputBox("Please input the raw data location and filename. E.g. C:\Users\Desktop\RawData.xls", "Filename")
Workbooks.Open Filename:=MyInput

Dim x1(3000)
Dim x2(3000)
Dim x3(3000)
Dim x4(3000)
Dim x5(3000)

For k = 1 To 5000
m = Workbooks("RawData.xls").Sheets("Prices").Cells(k, 1)
k_1 = k_1 + 1
If m = 0 Then Exit For
Next

For k = 1 To 5000
m = Workbooks("RawData.xls").Sheets("Prices").Cells(k, 4)
k_2 = k_2 + 1
If m = 0 Then Exit For
Next

For k = 1 To 5000
m = Workbooks("RawData.xls").Sheets("Prices").Cells(k, 7)
k_3 = k_3 + 1
If m = 0 Then Exit For
Next

For k = 1 To 5000
m = Workbooks("RawData.xls").Sheets("Prices").Cells(k, 10)
k_4 = k_4 + 1
If m = 0 Then Exit For
Next

For k = 1 To 5000
m = Workbooks("RawData.xls").Sheets("Prices").Cells(k, 13)
k_5 = k_5 + 1
If m = 0 Then Exit For
Next

For i = 1 To k_1
x1(i - 1) = Cells(i, 2)
Next i

For j = 1 To k_1
For i = 1 To k_2
If Cells(j, 1) = Cells(i, 4) Then
x2(j - 1) = Cells(i, 5)
Exit For
Else: x2(j - 1) = 0
End If
Next i
Next j

For j = 1 To k_1
For i = 1 To k_3
If Cells(j, 1) = Cells(i, 7) Then
x3(j - 1) = Cells(i, 8)
Exit For
Else: x3(j - 1) = 0
End If
Next i
Next j

For j = 1 To k_1
For i = 1 To k_4
If Cells(j, 1) = Cells(i, 10) Then
x4(j - 1) = Cells(i, 11)
Exit For
Else: x4(j - 1) = 0
End If
Next i
Next j

For j = 1 To k_1
For i = 1 To k_5
If Cells(j, 1) = Cells(i, 13) Then
x5(j - 1) = Cells(i, 14)
Exit For
Else: x5(j - 1) = 0
End If
Next i
Next j

k = 0

For i = 0 To k_1
If x1(i) = 0 Or x2(i) = 0 Or x3(i) = 0 Or x4(i) = 0 Or x5(i) = 0 Then
Else
Cells(k + 1, 2) = x1(i)
Cells(k + 1, 3) = x2(i)
Cells(k + 1, 4) = x3(i)
Cells(k + 1, 5) = x4(i)
Cells(k + 1, 6) = x5(i)
k = k + 1
End If
Next i

Range(Cells(k + 1, 1), Cells(k + 2000, 14)).Clear
Range(Cells(1, 7), Cells(k + 2000, 14)).Clear
Range(Cells(1, 4), Cells(k + 2000, 4)).NumberFormat = "General"

Dim RangeRawDates As Range, RangeDates As Range
Set RangeRawDates = Workbooks("RawData.xls").Sheets("Prices").Range("A1:F5000")
Set RangeDates = Workbooks("Result.xls").Sheets("Prices").Range("A1:F5000")

RangeRawDates.Copy RangeDates

End Sub

NewToVBAs · Apr 2, 2011

BUMP!

Would appreciate alot any help rendered! =)) Thanks much in advance!

Krishnakumar · Apr 2, 2011

Hi,

Untested.

Code:

Sub kTest()
    Dim ka, i As Long, n As Long, strFileName   As String, c As Long, t()
    Dim wbkActive As Workbook, wbkOpened As Workbook, dtCols, Flg As Boolean
    
    With Application.FileDialog(3)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        strFileName = .SelectedItems(1)
    End With
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    
    Set wbkActive = ThisWorkbook
    Set wbkOpened = Workbooks.Open(strFileName, 0)
    
    With wbkOpened.Worksheets("Prices")
        ka = Application.Intersect(.UsedRange, .Columns("a:n"))
    End With
    wbkOpened.Close 0
    Set wbkOpened = Nothing
    dtCols = Array(1, 4, 7, 10, 13)
    ReDim k(1 To UBound(ka, 1), 1 To 7)
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(ka, 1)
            For c = LBound(dtCols) To UBound(dtCols)
                If Len(ka(i, dtCols(c) + 1)) Then
                    If Not .exists(ka(i, dtCols(c))) Then
                        n = n + 1
                        k(n, 1) = ka(i, dtCols(c))
                        k(n, c + 2) = ka(i, dtCols(c) + 1)
                        k(n, 7) = 1
                    Else
                        t = .Item(ka(i, dtCols(c)))
                        k(t(0), dtCols(c) + 1) = ka(i, dtCols(c) + 1)
                        k(t(0), 7) = Len(k(t(0), 2)) + Len(k(t(0), 3)) + Len(k(t(0), 4)) + Len(k(t(0), 5)) + Len(k(t(0), 6))
                    End If
                End If
            Next
        Next
    End With
    
    With Worksheets("Prices").Range("a1")
        i = .CurrentRegion.Rows.Count
        .Offset(1).Resize(i, 7).ClearContents
        .Offset(1).Resize(n, 7).Value = k
        With .Resize(n + 1, 7)
            .AutoFilter field:=7, Criteria1:="<>5"
            .Offset(1, 1).Resize(.Rows.Count - 1, 6).SpecialCells(12).ClearContents
            .AutoFilter
        End With
        .Offset(1, 6).Resize(n).ClearContents
    End With
    With Application
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With
End Sub

NewToVBAs · Apr 2, 2011

hi Krishnakumar!

i've tried out e codes.. but it says subscript out of range =(

but i quite like e way e user can choose which file to open from!

thanks krishnakumar for the help!

Krishnakumar · Apr 2, 2011

Hi,

In which line ? Can you post a screen shot of your data ?

NewToVBAs · Apr 2, 2011

hi

it is in this line:

k(n, 1) = ka(i, dtCols(c))

here is the link to the screenshot of data & the line:
http://img853.imageshack.us/g/datas.jpg/

NewToVBAs · Apr 2, 2011

Jus realized im missing out a link to the screenshot for subscript out of range:

http://img8.imageshack.us/i/subscriptoutofrange.jpg/

Krishnakumar · Apr 2, 2011

Hi,

OK. This should do.

Code:

Sub kTest()
    Dim ka, i As Long, n As Long, strFileName   As String
    Dim wbkActive As Workbook, wbkOpened As Workbook
    Dim c As Long, t(), dtCols, j As Long, m As Long
    
    With Application.FileDialog(3)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        strFileName = .SelectedItems(1)
    End With
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    
    Set wbkActive = ThisWorkbook
    Set wbkOpened = Workbooks.Open(strFileName, 0)
    
    With wbkOpened.Worksheets("Prices")
        ka = Application.Intersect(.UsedRange, .Columns("a:n"))
    End With
    wbkOpened.Close 0
    Set wbkOpened = Nothing
    dtCols = Array(1, 4, 7, 10, 13)
    ReDim k(1 To UBound(ka, 1), 1 To 7)
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 2 To UBound(ka, 1)
            For c = LBound(dtCols) To UBound(dtCols)
                If Len(ka(i, dtCols(c) + 1)) Then
                    If Not .exists(ka(i, dtCols(c))) Then
                        n = n + 1
                        k(n, 1) = ka(i, dtCols(c))
                        k(n, c + 2) = ka(i, dtCols(c) + 1)
                        k(n, 7) = 1
                        .Add ka(i, dtCols(c)), Array(n, 7)
                    Else
                        t = .Item(ka(i, dtCols(c)))
                        k(t(0), c + 2) = ka(i, dtCols(c) + 1)
                        m = 0
                        For j = 2 To 6
                            If Len(k(t(0), j)) Then m = m + 1
                        Next
                        k(t(0), 7) = m
                    End If
                End If
            Next
        Next
    End With
    
    With Worksheets("Prices").Range("a1")
        i = .CurrentRegion.Rows.Count
        .Offset(1).Resize(i, 7).ClearContents
        .Offset(1).Resize(n, 7).Value = k
        With .Resize(n + 1, 7)
            .AutoFilter field:=7, Criteria1:="<>5"
            .Offset(1, 1).Resize(.Rows.Count - 1, 6).SpecialCells(12).ClearContents
            .AutoFilter
        End With
        .Offset(1, 6).Resize(n).ClearContents
    End With
    With Application
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With
End Sub

NewToVBAs · Apr 2, 2011

hi Krishnakumar

it still has subscript out of range error. =(

the error is in line "With Worksheets("Prices").Range("a1")"

Krishnakumar · Apr 2, 2011

Hi,

You should have a worksheet 'Prices' in the workbook, from where you run the macro.

or simly use

Code:

With Range("a1")

instead of

Code:

With Worksheets("Prices").Range("a1")

HTH

VBA need help here!

NewToVBAs

New Member

Excel Facts

NewToVBAs

New Member

Krishnakumar

Well-known Member

NewToVBAs

New Member

Krishnakumar

Well-known Member

NewToVBAs

New Member

NewToVBAs

New Member

Krishnakumar

Well-known Member

NewToVBAs

New Member

Krishnakumar

Well-known Member

Similar threads

Forum statistics

Share this page

VBA need help here!

New Member

Excel Facts

New Member

Well-known Member

New Member

Well-known Member

New Member

New Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock