I have 2 worksheets in the same workbook. If a cell in SourceSheet meets certain criteria, I want to copy several non-adjacent cells in the same row to NewSheet. The problem is that it's taking over a half second to paste each and every cell, making the macro far too slow. The code below takes 8 seconds to complete a single loop. Is there a faster way I could do this?
Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long
'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row
For row = 2 To lrow
With EnrollmentChanges
course1 = Sheets("SourceSheet").Range("A" & row)
If course1 <> "" Then
course1status = Sheets("SourceSheet").Range("BS" & row)
If InStr(1, course1, "APEX") And course1status = "1" Then
NewSheetRow = NewSheetRow + 1
Sheets("NewSheet").Range("A" & NewSheetRow) = NewSheetRow
Sheets("NewSheet").Range("B" & NewSheetRow) = "W"
Sheets("NewSheet").Range("C" & NewSheetRow) = "S"
Sheets("NewSheet").Range("D" & NewSheetRow) = "MySchool"
Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("G" & NewSheetRow)
Sheets("SourceSheet").Range("W" & row).Copy Sheets("NewSheet").Range("H" & NewSheetRow)
Sheets("SourceSheet").Range("V" & row).Copy Sheets("NewSheet").Range("J" & NewSheetRow)
Sheets("SourceSheet").Range("Y" & row).Copy Sheets("NewSheet").Range("K" & NewSheetRow)
Sheets("NewSheet").Range("L" & NewSheetRow) = "OR"
Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("M" & NewSheetRow)
Sheets("SourceSheet").Range("A" & row).Copy Sheets("NewSheet").Range("P" & NewSheetRow)
End If
Else: GoTo NextRow
End If
End With
NextRow:
Next
The best way to approach this would to be avoiding copy and paste altogether (which are notoriously slow). The only time that copy/paste MAY be worth keeping is when you need to copy formatting. If you just need the values then you can do something like this:
Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long
'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row
For row = 2 To lrow
With EnrollmentChanges
course1 = Sheets("SourceSheet").Range("A" & row)
If course1 <> "" Then
course1status = Sheets("SourceSheet").Range("BS" & row)
If InStr(1, course1, "APEX") And course1status = "1" Then
NewSheetRow = NewSheetRow + 1
With Sheets("NewSheet")
.Range("A" & NewSheetRow).Value = NewSheetRow
.Range("B" & NewSheetRow).Value = "W"
.Range("C" & NewSheetRow).Value = "S"
.Range("D" & NewSheetRow).Value = "MySchool"
.Range("G" & NewSheetRow.Value = Sheets("SourceSheet").Range("B" & row).Value
.Range("H" & NewSheetRow).Value = Sheets("SourceSheet").Range("W" & row).Value
.Range("J" & NewSheetRow).Value = Sheets("SourceSheet").Range("V" & row).Value
.Range("K" & NewSheetRow).Value = Sheets("SourceSheet").Range("Y" & row).Value
.Range("L" & NewSheetRow).Value = "OR"
.Range("M" & NewSheetRow).Value = Sheets("SourceSheet").Range("B" & row).Value
.Range("P" & NewSheetRow).Value = Sheets("SourceSheet").Range("A" & row).Value
End With
End If
' No need for this since you are skipping the operation using the if block
' GoTo is messy and should be avoided where possible as well.
'Else: GoTo NextRow
End If
End With
NextRow:
Next
All I did was swap the order and assign the value directly based on the value retrieved versus storing the value retrieved as a copy, and putting it in a new location. Once you practice this a bit it will make much more sense (and it will speed up your code considerably).
As noted at the beginning, if you need formatting kept then that is a bit different.
Also, I didnt bother with optimizing or indenting any of the other elements of your code, but you will want to clean it up with proper indenting and skipping things like "GoTo".
call this sub a the top of you macro:
Sub MakeItFaster()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
End Sub
Related
I have to update an excel data base that contains data from projects. Every week I have to download the new database that my company creates, with new projects and updated data from old projects. I want to create a macro that does this (update the new information from old projects and add new projects). The project names are unique. I tried using the next code to update the data automatically, but it doesn't do anything (my data base doesn't change) and I don't know why (every project is a row and every data from the project is a column)
Sub UpdateData()
Dim h1 As Workbook 'workbook where the data is to be pasted
Dim s1 As Worksheet
Dim h2 As Workbook 'workbook from where the data is to copied
Dim s2 As Worksheet
Dim strName As String 'name of the source sheet/ target workbook
Dim aCell As Range, bCell As Range
Dim SearchString As String
Dim ExitLoop As Boolean, matchFound As Boolean
'set to the current active workbook (the source book)
Set h2 = ActiveWorkbook
Set s2 = ActiveSheet
Set h1 = Workbooks.Open("C:\Users\BAICFL\Desktop\macro prueba.xlsx")
Set s1 = h1.Worksheets("Sheet1")
s2.Activate
Dim col As Long
Dim LastRow1 As Long
Dim row As Long
Dim i As Integer
Dim j As Integer
with s1
LastRow1 = .Range("E" & .Rows.Count).End(xlUp).Row
End With
with s2
LastRow2 = .Range("E" & .Rows.Count).End(xlUp).Row
End With
For i = 1 To LastRow1
For j = 1 To LastoRow2
If s2.Range("E" & j).Value = s1.Range("E" & i).Value Then
s1.Range("D" & i).Value = s2.Range("D" & j).Value
s1.Range("F" & i).Value = s2.Range("F" & j).Value
s1.Range("G" & i).Value = s2.Range("G" & j).Value
s1.Range("H" & i).Value = s2.Range("H" & j).Value
s1.Range("I" & i).Value = s2.Range("I" & j).Value
s1.Range("J" & i).Value = s2.Range("J" & j).Value
s1.Range("K" & i).Value = s2.Range("K" & j).Value
s1.Range("L" & i).Value = s2.Range("L" & j).Value
s1.Range("M" & i).Value = s2.Range("M" & j).Value
s1.Range("N" & i).Value = s2.Range("N" & j).Value
s1.Range("O" & i).Value = s2.Range("O" & j).Value
s1.Range("P" & i).Value = s2.Range("P" & j).Value
s1.Range("Q" & i).Value = s2.Range("Q" & j).Value
s1.Range("R" & i).Value = s2.Range("R" & j).Value
s1.Range("S" & i).Value = s2.Range("S" & j).Value
s1.Range("T" & i).Value = s2.Range("T" & j).Value
End If
Next
Next
End Sub
I believe the main problem with your code is that you are declaring and setting the worksheet as AcitveWorkbook and same for worksheet, and when working with more than one workbook, you should fully qualify your ranges, as you may be viewing another workbook and VBA will assume that that is the active one.
I've also did the transfer of data in a single line of code by copying a range into your destination.
You also had a typo on your second For Loop, instead of LastRow2 you had LastoRow2...
Also i and j should be declared as Long instead of integers, have a look at the code below:
Sub UpdateData()
Dim LastRow1 As Long, LastRow2 As Long, i As Long, j As Long
Dim h1 As Workbook
Dim s1 As Worksheet
Dim h2 As Workbook: Set h2 = ThisWorkbook
Dim s2 As Worksheet: Set s2 = h2.Worksheets("Sheet1")
'declare and set your workbook/worksheet amend as required
Set h1 = Workbooks.Open("C:\Users\BAICFL\Desktop\macro prueba.xlsx")
Set s1 = h1.Worksheets("Sheet1")
LastRow1 = s1.Cells(s1.Rows.Count, "E").End(xlUp).row
LastRow2 = s2.Cells(s2.Rows.Count, "E").End(xlUp).row
For i = 1 To LastRow1
For j = 1 To LastRow2
If s2.Range("E" & j).Value = s1.Range("E" & i).Value Then
s1.Range("D" & i & ":T" & i).Copy s2.Range("D" & j & ":T" & j)
End If
Next j
Next i
End Sub
I have written the following code; both Sheet 1 and Sheet 2 are rather big sheet with lots of data. Run this Macro is extremely time comsuming ( It has a high complexity I guess). I'm quite new at VBA and therefore having trouble make the code more effective.
Sub Find()
Dim rgFound As Range
Dim Index As Long: Index = 6
Dim Row as Long
Do While Worksheets("Sheet2").Cells(Index, "D").Value > 0
Sheets("Sheet1").Select
Set rgFound = Range("A1:A20000").Find(Worksheets("Sheet2").Cells(Index, "D").Value)
If Not rgFound Is Nothing Then
Row = rgFound.Row
Worksheets("Sheet1").Range("E" & Row).Value = Worksheets("Sheet2").Range("AA" & Index).Value
Worksheets("Sheet1").Range("F" & Row).Value = Worksheets("Sheet2").Range("AB" & Index).Value
Worksheets("Sheet1").Range("G" & Row).Value = Worksheets("Sheet2").Range("AC" & Index).Value
Worksheets("Sheet1").Range("H" & Row).Value = Worksheets("Sheet2").Range("Z" & Index).Value
Worksheets("Sheet1").Range("J" & Row).Value = Worksheets("Sheet2").Range("AG" & Index).Value
Worksheets("Sheet1").Range("I" & Row).Value = Worksheets("Sheet2").Range("AD" & Index).Value
Else
' Function // Not done yet
End If
Index = Index + 1
Loop
End Sub
Is the built in Find function effective? The loop loops trough roughly 250-400 values. Any Ideas?
I'm trying to create a Macro that will modify contents in columns S, W and AH based on the content in AB
e.g. if AB1 = No, then S1=C-MEM, AH = N/A and W is cleared.
For some reason, I get a 'Type mismatch' error on the first line of my if statement and can't figure out why or how to fix it - even after reading other posts about similar issue.
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
**-> If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
Next i
End Sub
Thanks
You are trying to test if an error is = No.
Test for the error and skip the logic in that loop:
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AB" & i).Value) Then
If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
End If
Next i
End Sub
I want to create a macro that check all the cells of a column and if the first two characters of a cell is "BB" then i want the macro to extract three characters from the cell and paste it to the next column but a the corresponding row.
But my formula after the if clause is not working.
this is what i have done since:
Sub test()
Dim lmid As String
Dim srange, SelData, ExtBbFor As String
Dim lastrow As Long
Dim i, icount As Integer
lastrow = ActiveSheet.Range("B30000").End(xlUp).Row
srange = "G1:G" & lastrow
SelData = "A1:G" & lastrow
Range(srange).Formula = "=mid(E1,1,3)"
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "bb") <> 0 Then
Range("G" & i).Formula = "=mid("E & i", 4, 3)"
End If
Next i
End Sub
thanks in advance
Try with below. It will work
Range("G" & i).Value = Mid(Range("E" & i), 4, 3)
If the cell is not limited to 7 then you need as below
Range("G" & i).Value = "=Mid(E" & i & ", 3, " & Len(E & "& i & ") & ")"
It will extract from the 3rd character up to the last character in a cell.
Your syntax is wrong where you're trying to concatenate strings, I think you mean to use:
Range("G" & i).Formula = "=MID(E" & i & ",4,3)"
Based on your code I think this will do the exact same thing without having to loop or declare any variables:
Sub test()
With Range("G1:G" & Cells(Rows.Count, 2).End(xlUp).Row)
.FormulaR1C1 = "=IF(UPPER(LEFT(RC[-2],2))=""BB"",MID(RC[-2],4,3),"""")"
.Value = .Value
End With
End Sub
As mentioned in the title, I need a VBA equivalent to the Excel Value function. My data set looks like this: Data set example
What I am looking for is VBA code equivalent to this: =Value(A2)+Value(B2). That would go in column C
The output must be the same as that function. For the given example, column C should end up looking like this: End product
More than that, it needs to only have the value in the cell after the macro is run, rather than displaying the value and still having that formula in it.
Here is what I have done so far:
For i = 1 To LastRow
strValue = Val(sht.Range("A" & i))
strValue1 = Val(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
I also tried variations on this, a couple of which are shown below:
For i = 1 To LastRow
strValue = Evaluate(sht.Range("A" & i))
strValue1 = Evaluate(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
For i = 1 To LastRow
strValue = sht.Range("A" & i)
strValue1 = sht.Range("B" & i)
strVal = Evaluate(strValue)
strVal1 = Evaluate(strValue1)
sht.Range("C" & i).Value = strVal + strVal1
Next i
I can't find anything that will work for me. The output in C for the example set ends up being just 9. Pretty sure it is taking the first number in A and adding it to the first number in B. So when the hour in B changes to 1 C displays 10.
I also tried simply:
For i=1 To LastRow
sht.Range("C" & i).Value = sht.Range("A" & i).Value + sht.Range("B" & i).Value
Next i
That just concatenated the text to the format 9/03/15 00:00:00
Any and all help appreciated. Bonus if you can point me in the right direction for changing the final C values from that number (ie. 42250.00017) to the custom date/time format 'yyyy-mm-dd hh:mm:ss'.
Edit: Here is my code up to the sticking point. Everything else works as I want it to, the only problem is with the last For loop.
Sub sbOrganizeData()
Dim i As Long
Dim k As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim sFound As String
Dim rng As Range
Dim sheet As Worksheet
Dim Sheet2 As Worksheet
Dim strFile As String
Dim strCSV As String
Dim strValue As Double
Dim strValue1 As Double
Dim strVal As Long
Dim strVal1 As Long
Application.DisplayAlerts = False
Sheets("all016").Delete
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
Set sheet = Sheets.Add
Set Sheet2 = Sheets.Add
sheet.Name = "all016"
Sheet2.Name = "Sheet1"
strFile = ActiveWorkbook.Path
strCSV = "*.csv"
sFound = Dir(strFile & "\*.csv")
If sFound <> "" Then
Workbooks.Open Filename:=strFile & "\" & sFound
End If
Range("A1").CurrentRegion.Copy Destination:=Workbooks("solar.xlsm").Sheets("all016").Range("A1")
Workbooks(sFound).Close
Set sht = ThisWorkbook.Sheets("all016")
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
sht.Range("C1").EntireColumn.Insert
For i = 1 To LastRow
'Code that doesn't quite work here'
sht.Range("C" & i).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Next i
The issue is that the dates and times are strings so something like this will work:
For i = 2 To LastRow
strValue = Evaluate("VALUE(TRIM(" & sht.Range("A" & i).Address(1,1,,1) & "))")
strValue1 = Evaluate("VALUE(TRIM(" & sht.Range("B" & i).Address(1,1,,1) & "))")
sht.Range("C" & i).Value = strValue + strValue1
'the format
sht.Range("C" & i).NumberFormat = "mm/dd/yy hh:mm:ss"
Next i
You have to reference the .Value2 field of the range element as:
For i = 1 To LastRow
sht.Range("C" & i).Value2 = sht.Range("A" & i).Value2 + sht.Range("B" & i).Value2
Next i
The value is free of formatting and just in Excel's time/date code as you want your final result to be. Cheers,