VBA, IF THEN, SELECT CASE or ...

[sylwester.cz]

Hello All,

First of all Happy Easter to all of you!

I am a beginner in VBA and mostly self learner (using various examples if this forum and other internet sources). Currently I need to write a code however I faced a wall and I am stucked there. The code you will see in the VBA editor took me few hours to write, it is quite tough for me still.

Anyway, I hope you can help me to find a good solution. Short explanation:

Data table is in "Revenues" sheet. Currently there are 4 columns (from "I" to "L") with different revenues values for each month, Rev1, Rev2, Rev3 and Rev4.
- If there is a value in cell for example "I3" then it should copy the rage "B3:H3" and also that value in I3 + preferably column heading (as it is show in "desired outcome" sheet).
- then there is another value for Jan in cell "J3". Again, range "B3:H3" and that value in J3 + preferably column heading.
- and so on..

Link to the excel file: Download project.xlsm from Sendspace.com - send big files the easy way

You will notice that my macro is far away from the desired result. Any help will be very appreciated.

Thank you in advance!
Sylwester

 

[par60056]

I looked at the file that you put out with data and realized you need to save the values from the beginning columns too.

Try this and see if it is close to what you want.

Sub UpdateDatabase()


Dim CopyFrom As String
Dim CopyTo As String
Dim outRow As Long
Dim currRow As Long
Dim lastRow As Long
Dim currCol As Integer
Dim revCol As Integer
Dim Test As Integer
Dim values(10) As String




CopyFrom = "Revenues"
CopyTo = "output"


'Clean the worksheet from old data
Worksheets(CopyTo).UsedRange.ClearContents


lastRow = Sheets(CopyFrom).Cells(2, 7).End(xlDown)


'To which line it should start copy data to "output"
DataCount = 2


' for speed, turn of screen updating and recalculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For currRow = 3 To lastRow
    
    ' check to see if any of the first 7 columns are filled and save them for output
    For currCol = 2 To 7
        If (Cells(currRow, currCol) <> "") Then
            values(currCol - 1) = Cells(currRow, currCol)
        End If
    Next
    
    'check each rev column on the row
    For revCol = 9 To 12
        If (Cells(currRow, revCol) > 0) Then
            'output saved columns values and the header from the rev column
            For currCol = 1 To 6
                Sheets(CopyTo).Cells(DataCount, currCol) = values(currCol)
            Next
            Sheets(CopyTo).Cells(DataCount, 7) = Cells(2, revCol)
            DataCount = DataCount + 1
        End If
    Next revCol
Next currRow


'turn caculation and updating back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[sylwester.cz]

Hi Par60056,

I have tried to run your code but got Run-time error '13', Type mismatch on the below row:

lastRow = Sheets(CopyFrom).Cells(2, 7).End(xlDown)

When I point mouse on xlDown text I see value -4121.

I've tried to figure out why it pops up but with no luck so far

Would you please look at it one more time?

 

[sylwester.cz]

Hi again,

I have modifed your code and it runs almost OK. It copies all the data except the revenue value from columns H to K (I have enclosed updated file & code). Would you please look at it when you have a moment?

Download project_mrexcel.xlsm from Sendspace.com - send big files the easy way

Option Explicit

Sub MrExcel()

Dim CopyFrom As String
Dim CopyTo As String
Dim outRow As Long
Dim currRow As Integer
Dim lastRow As Long
Dim currCol As Integer
Dim revCol As Integer
Dim Test As Integer
Dim values(10) As String
Dim DataCount As Long

CopyFrom = "Revenues"
CopyTo = "output"

'Clean the worksheet from old data
Worksheets(CopyTo).UsedRange.ClearContents

'lastRow = Sheets(CopyFrom).Cells(2, 7).End(xlDown)
lastRow = 20

'To which line it should start copy data to "output"
DataCount = 2

' for speed, turn of screen updating and recalculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For currRow = 3 To lastRow
    
    ' check to see if any of the first 7 columns are filled and save them for output
    For currCol = 1 To 7
        If (Cells(currRow, currCol) <> "") Then
            values(currCol) = Cells(currRow, currCol)
        End If
    Next
    
    'check each rev column on the row
    For revCol = 8 To 11
        If (Cells(currRow, revCol) > 0) Then
            'output saved columns values and the header from the rev column
            For currCol = 1 To 10
                Sheets(CopyTo).Cells(DataCount, currCol) = values(currCol)
            Next
            Sheets(CopyTo).Cells(DataCount, 9) = Cells(2, revCol)
            DataCount = DataCount + 1
        End If
    Next revCol
Next currRow


'turn caculation and updating back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[par60056]

forgot to put ".Row" at the end.

Line should be:
lastRow = Sheets(CopyFrom).cells(2,7).End(xlDown).Row

When I copied your sheet to try and test it, I see that you have all of the values in columns B-F. There are easier ways to copy them but this does work.

I also ran into a problem when it hit row 29 and the value is invalid. Looks like you stopped copying the formula.

 

[par60056]

ok I fixed the last row issue. and I added a line to get the value over.

Option Explicit


Sub MrExcel()


Dim CopyFrom As String
Dim CopyTo As String
Dim outRow As Long
Dim currRow As Integer
Dim lastRow As Long
Dim currCol As Integer
Dim revCol As Integer
Dim Test As Integer
Dim values(10) As String
Dim DataCount As Long


CopyFrom = "Revenues"
CopyTo = "output"


'Clean the worksheet from old data
Worksheets(CopyTo).UsedRange.ClearContents


lastRow = Sheets(CopyFrom).Cells(2, 7).End(xlDown).Row
'lastRow = 20


'To which line it should start copy data to "output"
DataCount = 2


' for speed, turn of screen updating and recalculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For currRow = 3 To lastRow
    
    ' check to see if any of the first 7 columns are filled and save them for output
    For currCol = 1 To 7
        If (Cells(currRow, currCol) <> "") Then
            values(currCol) = Cells(currRow, currCol)
        End If
    Next
    
    'check each rev column on the row
    For revCol = 8 To 11
        If (Cells(currRow, revCol) > 0) Then
            'output saved columns values and the header from the rev column
            For currCol = 1 To 7
                Sheets(CopyTo).Cells(DataCount, currCol) = values(currCol)
            Next
            Sheets(CopyTo).Cells(DataCount, 8) = Cells(currRow, revCol).Value
            Sheets(CopyTo).Cells(DataCount, 9) = Cells(2, revCol)
            DataCount = DataCount + 1
        End If
    Next revCol
Next currRow




'turn caculation and updating back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
[CODE]

 

[sylwester.cz]

Hi again,

THANK YOU VERY MUCH for your help and time! It works great now. I will of course study the code and try to use it in the future.

Have a great evening!
Sly

 

[sylwester.cz]

Hi again,

I have added few columns to my main file and changed the code accordingly but now I get "Run-time error 9, Subscript out of range" on the row highlited below (column 11).

I also noticed that if I change columns from 1 To 10 instead of 11 then the code works without error. Why does it happen? Is there any limitation in terms of number of columns?

For currRow = 3 To lastRow

' check to see if any of the first 12 columns are filled and save them for output
For currCol = 1 To 11
If (Cells(currRow, currCol) <> "") Then
[SIZE=4][U][B]values(currCol) = Cells(currRow, currCol)[/B][/U][/SIZE]
End If
Next


'check each rev column on the row
For revCol = 12 To 22
If (Cells(currRow, revCol) > 0) Then
'output saved columns values and the header from the rev column
For currCol = 1 To 11
Sheets(CopyTo).Cells(DataCount, currCol) = values(currCol)
Next
Sheets(CopyTo).Cells(DataCount, 12) = Cells(currRow, revCol).Value
Sheets(CopyTo).Cells(DataCount, 13) = Cells(2, revCol)
DataCount = DataCount + 1
End If
Next revCol
Next currRow

 

[par60056]

Where did you add the columns? The looping that I wrote assumed that the 8-11 on the original sheet and that 1-7 are simply copied. You need to adjust the column numbers on the for loops and the hard coded columns for placing the revenue numbers and the revenue column header in columns 8 & 9

 

[par60056]

You are running into a problem because I only made the values array 10 long.

Dim values(10) as string

change to

Dim values(20) as string