I am currently working with 3 files: New file (Sht)- in which the macro is written and the other two are wsSource and wsDest. There are about 1000 rows in the new file and about 1000 rows in wsSource. LastRowAT is the last row of the New File. LastRowKS is the last row of wsDest.
The code matches particular conditions and then based on these conditions, copies the data from wsSource to wsDest.
Now, because I am using a for loop and nested if, sometimes excel crashes and has to restart.
Can I optimize this piece of code in any manner so that it takes less time to run and more importantly does not crash?
P.S This is just sample data. The real data would involve about 100,000 rows in the wsSource file
For i = 2 To LastRowAT
If sht.Range("B" & i).Value = "Khusbhu Singh" And sht.Range("D" & i).Value = "Allocated" And sht.Range("C" & i).Value = Max_date Then
If sht.Range("A" & i).Value = Workbooks("CISF.xlsx").Worksheets("QUIDAM-INSURERS").Range("A" & i).Value Then
Set rngCopy = wsSource.Range("A" & i & ":V" & i)
rngCopy.Copy wsDest.Cells(LastRowKS, "I")
wsDest.Cells(LastRowKS, "I").Resize( _
rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value
wsDest.Range("A" & LastRowKS).Value = "Khusbhu Singh"
wsDest.Range("B" & LastRowKS).Value = Max_date
LastRowKS = LastRowKS + 1
End If
End If
Next i
My code does what I want, but it copies it to column A in sheet 2. I would like it to put the data in starting at Column B if possible.
Sub EFP()
Dim keyword As String: keyword = Sheets("Results").Range("B3").Value
Dim countRows1 As Long, countRows2 As Long
countRows1 = 3 'the first row of my dataset in the Data tab
endRows1 = 500 'the last row of my dataset in the Data tab
countRows2 = 6 'the first row where I want to start writing the found rows
For j = countRows1 To endRows1
If Sheets("Data").Range("B" & j).Value = keyword Then
Sheets("Results").Rows(countRows2).Value = Sheets("Data").Rows(j).Value
countRows2 = countRows2 + 1
End If
Next j
End Sub
If you copy and paste whole rows, they will always start in column A. If you want the result to start in column B, you need a different approach, for example
Sheets("Results").Range("B" & countRows2 & ":Z" & countRows2).Value = Sheets("Data").Range("A" & j & ":Y" & j).Value
I am new at Excel VBA and despite my efforts I cannot seem to find a similar example online to use as a solution to my issue.
I am creating a table of data related to an inventory of automobiles. The workbook that I have set up has two tabs. The first is labeled "FEEDER", and contains a table of hardcoded inputs (automobile values). The second is labeled "Sheet1" and contains raw data for all inventory. Sheet 1 requires automobile values in column "I". My goal is to set the workbook up so that a Column I labeled "Values" within "Sheet1", would be autopopulated with the click of a button from value inputs from the FEEDER sheet. The tricky part (for me) is that the values are based on 1) the automobile type (i.e. sedan/ pickup/ etc.), 2) the color (different colors have slightly different values), and 3) the Manufacture year. I was approaching this at first like an IF AND statement, but thought creating a macro would be a more efficient route to take.
I have a working list, but many more automobile types to go (400+ total). If I could get a some help at thsi stage I can [hopefully] figure out the rest.
Your help would be greatly appreciated.
Screen Shots here: FEEDER Table and SHEET1 Inventory List
My code:
Sub ValueFill()
Dim x As Integer
For x = 3 To Range("A" & Rows.Count).End(xlUp).Row
If UCase(Sheets("Sheet1").Range("A" & x).Text) = "Pickup*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Red*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("C" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
ElseIf UCase(Sheets("Sheet1").Range("A" & x).Text) = "Pickup*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Blue*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("D" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
ElseIf UCase(Sheets("Sheet1").Range("A" & x).Text) = "Sedan*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Red*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("E" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
ElseIf UCase(Sheets("Sheet1").Range("A" & x).Text) = "Sedan*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Blue*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("F" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
'I would keep "ElseIf-ing" for each combination of auto type and color, then index match by year...
Else: Range("I" & x).Text = "Error"
End If
Next
End Sub
My knee-jerk reaction is to use two different functions, since color and type are interdependent: one for handling the year and one for handling the type and color of the vehicle. Something like
Sub ValueFill()
For car = 1 to last 'this is your loop over the cars in Sheet1
color = type_color(car)
year = get_year(car)
price = Sheets("FEEDER").Cells(year, color).value
Function get_year(car)
'gets the year value for a give car and returns the corresponding row
number of that year, i.e car year 2009 is row 10 in FEEDER
End Function
Function type_color()
'will first get the type then convert based on color
'gets the type of the car and returns the left column index for that type
'i.e. type = pickup then column index = 3 (Column C)
if color not same as column value from above then
offset it
'i.e. for a blue pickup column index + 1 -> 4
end function
Here is a partial rewrite of your sample code. It isn't enough to finalize the module but perhaps it can get you started.
Sub ValueFill()
Dim x As Long, wsf As Worksheet, app As Application
Set app = Application
Set wsf = Sheets("FEEDER")
With Sheets("Sheet1")
For x = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
Select Case Left(LCase(.Cells(x, 1).Text), 5)
Case "picku"
Select Case Left(LCase(.Cells(x, 3).Text), 3)
Case "red"
'unclear on whether you want a value or a formula - pick one of these
.Range("I" & x).Value = app.Index(wsf.Columns(3), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
'.Range("I" & x).Formula = "=INDEX(Feeder!C:C, MATCH(F" & x & ", Feeder!B:B, 0))"
'.Range("I" & x).FormulaR1C1 = "=INDEX(Feeder!C3, MATCH(RC6, Feeder!C2, 0))"
Case "blu"
.Range("I" & x).Value = app.Index(wsf.Columns(4), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
Case Else
'do nothing
End Select
Case "sedan"
Select Case Left(LCase(.Cells(x, 3).Text), 3)
Case "red"
.Range("I" & x).Value = app.Index(wsf.Columns(5), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
Case "blu"
.Range("I" & x).Value = app.Index(wsf.Columns(6), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
Case Else
'do nothing
End Select
Case Else
Debug.Print "not it"
End Select
Next x
End With
Set wsf = Nothing
Set app = Nothing
End Sub
If more information about the nature of the FEEDER worksheet was provided, a one-size-fits-all formula may be able to be developed.
Actually, I am not familiar with excel functions. But, I can do it with vba code only.
Thanks, this is very good question. Try it with my idea.
Here, my approach for your problem. You don't need anything to modify. Just copy and run. It work well.
Public Sub fillValue()
Dim inventorySheet, priceSheet As Worksheet
Dim inventoryRow, priceRow As Integer
Dim redPickup, bluePickup, redSedan, blueSedan, redRoadster, blueRoadster As String
Dim automobileType, automobileColor, automobilePrice As String
Dim isFound As Boolean
'Set sheet for common use.
Set inventorySheet = ThisWorkbook.Worksheets("Sheet1")
Set priceSheet = ThisWorkbook.Worksheets("FEEDER")
'Price list in FEEDER sheet are stable.
'So, we can use them as constant.
'I initialize them as follow. You can add more column.
redPickup = "C"
bluePickup = "D"
redSedan = "E"
blueSedan = "F"
redRoadster = "G"
blueRoadster = "H"
'Set the start row Sheet1 sheet
inventoryRow = 3
'Looping all data from "Sheet1" sheet.
'One thing that the main colum is Automobile Type. So, loop until it is blank.
Do While inventorySheet.Range("A" & inventoryRow) <> ""
'First, get the price row from FEEDER sheet for manufacture year.
'Reset flag.
isFound = False
'Set the start row of FEEDER sheet.
priceRow = 4
'Loop manufacture year column of FEEDER sheet until blank
Do While priceSheet.Range("B" & priceRow) <> ""
If priceSheet.Range("B" & priceRow) = inventorySheet.Range("F" & inventoryRow) Then
'Set true for exist record for manufacture year
isFound = True
'Exit loop
Exit Do
End If
priceRow = priceRow + 1
Loop
'If there is no record for price, we should not do anything.
'If price record for manufacture year is exist, take the price.
If isFound Then
'Second, getting the automobile type from Sheet1.
'Get Automobile Type from sheet
automobileType = inventorySheet.Range("A" & inventoryRow)
'Split by space
splitedValues = Split(Trim(automobileType), " ")
'Get last word for automobile type
automobileType = splitedValues(UBound(splitedValues))
'Third, get the automobile color.
'Get Automobile Color from sheet.
automobileColor = inventorySheet.Range("C" & inventoryRow)
'Split by "-"
splitedValues = Split(Trim(automobileColor), "-")
'Get first word for automobile type
automobileColor = splitedValues(LBound(splitedValues))
'Reset automobile price.
automobilePrice = ""
'Fouth, check type and color and get price
Select Case automobileType
Case "Roadster"
If automobileColor = "Red" Then
automobilePrice = priceSheet.Range(redRoadster & priceRow)
Else
automobilePrice = priceSheet.Range(blueRoadster & priceRow)
End If
Case "Sedan"
If automobileColor = "Red" Then
automobilePrice = priceSheet.Range(redSedan & priceRow)
Else
automobilePrice = priceSheet.Range(blueSedan & priceRow)
End If
Case "Pickup"
If automobileColor = "Red" Then
automobilePrice = priceSheet.Range(redPickup & priceRow)
Else
automobilePrice = priceSheet.Range(bluePickup & priceRow)
End If
End Select
'Fifth, set the price in inventory sheet.
inventorySheet.Range("I" & inventoryRow) = automobilePrice
Else
'Set error for miss.
inventorySheet.Range("I" & inventoryRow) = "Error"
End If
'Increase inventory row
inventoryRow = inventoryRow + 1
Loop
End Sub
Here, my evidence for your problem.
My prepare data for "Sheet1" sheet.
My prepare data for "FEEDER" sheet.
After running code, I got this result.
Have a nice job..!
I have a sheet with multiple data in 1 cell this happen in a couple of columns. What I need to do is split the cell into individual rows while still keep the details from the other columns
Screen 1 shows the data i got
http://imageshack.com/a/img845/1783/wxc8.png (Screen 1)
Screen 2 is what i wish the macro to output.
http://imageshack.com/a/img842/7356/7yra.png (screen 2)
The macro i found and edited in only allows me to split 1 column and i can't get the editing of the range right. the columns that needs to be split is "J" "K" "N" and "O". The columns "A"- "I" and "L""M" just needs to copy their content to the new row.
Thank you in advance for the help.
Here the Macro im using
Sub Splt1()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("J" & Rows.Count).End(xlUp).Row
Columns("J").Insert
For i = LR To 1 Step -1
With Range("K" & i)
If InStr(.Value, Chr(10)) = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, Chr(10))
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("K").Delete
LR = Range("J" & Rows.Count).End(xlUp).Row
With Range("L1:M" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
The problem appears to be the with operator. It constrains your selection. Try reformulating your macro without the with and refer to the the ranges direct. For example, replace your first for loop with something like this:
For i = LR To 1 Step -1
If InStr(Range("K" & i).Value, Chr(10)) = 0 Then
Range("K" & i).Offset(, -1).Value = Range("K" & i).Value
'Range("J" ...
'Range("N" ...
'Range("O" ...
Else
K_collection = Split(Range("K" & i).Value, Chr(10))
Range("K" & i).Offset(1).Resize(UBound(K_collection)).EntireRow.Insert
Range("K" & i).Offset(, -1).Resize(UBound(K_collection) - LBound(K_collection) + 1).Value = Application.Transpose(K_collection)
'J_collection = Split(Range("J"...
'N_collection = Split(Range("N"...
'O_collection = Split(Range("O"...
End If
Next i
In general I avoid with because it tends to obscure the visual pattern of code.
You might also consider eliminating the .INSERT and .DELETE columns, and overwrite directly to the cells. When working with more than one at a time, it becomes hard to keep track which column is temporary and which one is the source. But that all depends on your preference.
Copying values for the other columns should be easy compared to this.
I am trying to modify my code to allow more factors to be taken into account when running a loop. Here is what I have so far, it's a loop running for i = 2 to 605 (because between 2 and 605, my G column's value is always the same "Makati City").
For this loop, I have some actions defined and it's working well. Here is the relevant code showing what my loop is doing :
For i = 2 To lRowBldg
Range("B" & i).Activate
'try to find a match btwn active cell and one of the elements from parsed address
For Each cell In elementsListRange.Cells
If Match(ActiveCell.Value, cell.Value) Then
Range("K" & i).Value = Range("K" & i).Value + 13
Else
Range("K" & i).Value = Range("K" & i).Value + 0
End If
If Match(ActiveCell.Offset(0, 4).Value, cell.Value) Then
Range("K" & i).Value = Range("K" & i).Value + 8
Else
Range("K" & i).Value = Range("K" & i).Value + 0
End If
Next
Next i
But as I plan to make some modifications to this file, I need to rethink my code. So far, I had only this file for one city so basically I could loop from the first to the last value and it was ok. Now, I plan to add more cities : for example, from 2 to 605 (Makati City), from 606 to 900 (blabla City), from 901 to ... and so on.
What I try to do is something like this :
"Loop for as long as the value of the cell in G column is equal to XXXXX (could be Makati City, could be blabla City, whatever)"
And if I mention Makati City, it will loop for i = 2 to 605, if it's blabla City, then it will loop for i = 606 to 900, and so on.
Do you have any idea about how to do this in such a way that wouldn't be too resource consuming as my file could end up being very long ?
Thanks so much in advance !
Use a while?
Here is some Idea....
Sub Test()
dim rng as range
rng = worksheet.find
While rng.Value2 LIKE "Makhati City"
'your logic here
rng.offset(row+1,col+0 or like this)
Wend
End Sub
you could try this, using columns L & N, and avoiding a loop entirely:
put all the code in a standard module then modify the code in setColumnKValues to search for differenct cioy names in column G.
ASSUMPTIONS:
That the differencet cities will be grouped together
that you can use a couple of extra columns (in this case L & N) as intermediates
that you will call setFormulasColumnK in the order of the cities on the sheet
that, based on the code in your question, you want to add a number to column K if the condition is met.
How does it work:
first, in column N we put marker values showing where the city changes
then, in column L we put in a formula, if it matches the city passed in, then L=K+13
finally, we copy paste the new values in column K, and clear columns L & N
Private oLastRange As Range
Private iFirstCell As Integer
Private iLastCell As Integer
Private lLastRow As Long
Sub setFormulasColumnK(ByVal sCity As String)
Dim sFormula As String
Dim oRange As Range
lLastRow = Cells(Rows.Count, Range("G1").Column).End(xlUp).Row
Range("N4:N" & lLastRow).Formula = "=IF(G4<>G5,NA(),"""")"
If Not Range("G:G").Find(sCity) Is Nothing Then
iFirstCell = Range("G:G").Find(sCity).Row
Else
Exit Sub
End If
Set oRange = Range("N" & iFirstCell)
iLastCell = Range("N" & iFirstCell & ":N" & lLastRow).Find("#N/A", oRange).Row
Range("L" & iFirstCell & ":L" & iLastCell).Formula = "=IF(TRIM(G:G)=""" & sCity & """,K:K+13,0)"
Set oLastRange = Range("L" & iLastCell)
End Sub
Sub setColumnKValues()
Set oLastRange = Nothing
Call setFormulasColumnK("Makati City")
'MsgBox oLastRange.Address
Call setFormulasColumnK("London")
'MsgBox oLastRange.Address
Call setFormulasColumnK("Birmingham")
'MsgBox oLastRange.Address
Call setFormulasColumnK("Moscow")
'MsgBox oLastRange.Address
Call setFormulasColumnK("Luxembourg")
'MsgBox oLastRange.Address
Call setFormulasColumnK("Paris")
'MsgBox oLastRange.Address
Range("L4" & ":L" & lLastRow).Copy
Range("K4" & ":K" & lLastRow).PasteSpecial xlPasteValues
Range("N4:N" & lLastRow).Clear
Range("L4" & ":L" & lLastRow).Clear
End Sub