This is looping through a worksheet that is about 10k rows and it is taking a considerable amount of time. Is there a way to do this faster aside from an array? thank you
For i = 2 To spberowcnt
With spbe30
.Range("b" & i).Value = LCase(.Range("b" & i).Value)
.Range("d" & i).Value = LCase(.Range("d" & i).Value)
.Range("i" & i).Value = LCase(.Range("i" & i).Value)
.Range("j" & i).Value = LCase(.Range("j" & i).Value)
.Range("l" & i).Value = LCase(.Range("l" & i).Value)
.Range("m" & i).Value = LCase(.Range("m" & i).Value)
.Range("n" & i).Value = LCase(.Range("n" & i).Value)
.Range("p" & i).Value = LCase(.Range("p" & i).Value)
.Range("q" & i).Value = LCase(.Range("q" & i).Value)
.Range("r" & i).Value = LCase(.Range("r" & i).Value)
.Range("z" & i).Value = LCase(.Range("z" & i).Value)
.Range("aa" & i).Value = LCase(.Range("aa" & i).Value)
End With
Next i
For i = 2 To spberowcnt
With spbe60
.Range("b" & i).Value = LCase(.Range("b" & i).Value)
.Range("d" & i).Value = LCase(.Range("d" & i).Value)
.Range("i" & i).Value = LCase(.Range("i" & i).Value)
.Range("j" & i).Value = LCase(.Range("j" & i).Value)
.Range("l" & i).Value = LCase(.Range("l" & i).Value)
.Range("m" & i).Value = LCase(.Range("m" & i).Value)
.Range("n" & i).Value = LCase(.Range("n" & i).Value)
.Range("p" & i).Value = LCase(.Range("p" & i).Value)
.Range("q" & i).Value = LCase(.Range("q" & i).Value)
.Range("r" & i).Value = LCase(.Range("r" & i).Value)
.Range("z" & i).Value = LCase(.Range("z" & i).Value)
.Range("aa" & i).Value = LCase(.Range("aa" & i).Value)
End With
Next i
This is the array solution
Sub test()
Application.ScreenUpdating = False
Dim arrWorksheets(1) As Variant, ws As Worksheet
Set arrWorksheets(0) = spbe30
Set arrWorksheets(1) = spbe60
Dim arrColumns As Variant
arrColumns = Array("B", "D", "AA") 'adjust to your needs
Dim arrValues As Variant
Dim iWs As Long, iC As Long, i As Long
For iWs = 0 To UBound(arrWorksheets)
Set ws = arrWorksheets(iWs)
For iC = 0 To UBound(arrColumns)
arrValues = ws.Range(arrColumns(iC) & "2").Resize(spberowcnt).Value
For i = 1 To UBound(arrValues, 1)
arrValues(i, 1) = LCase(arrValues(i, 1))
Next
ws.Range(arrColumns(iC) & "2").Resize(spberowcnt).Value = arrValues
Next
Next
Application.ScreenUpdating = True
End Sub
Alternative: helper columns ...
You could try something like the following, looping over the columns instead of the individual cells and using Evaluate and Lower on the entire column. You could also process adjacent columns together.
cols = Array("B", "D", "I:J", "L:N", "P:R", "Z:AA")
For i = LBound(cols) to Ubound(cols)
Dim col As String
col = cols(i)
With spbe30
Dim rng As Range
Set rng = .Rows("2:" & spberowcnt).Columns(col)
rng.Value = .Evaluate("LOWER(" & rng.Address & ")")
End With
Next
But as mentioned in comments, an array is probably the way to go.
Related
Hi Stackoverflow troops,
My time has finally come to ask a question rather than rely on all the answers as I'm stuck!
I've got a dataset showing the input table on the left & the output table on the right. The first date range interates as I'd expect, however I can't get the next rows to iterate their date ranges or indeed the other cells to be populated. Step 1 is to get the dates to iterate.
https://i.stack.imgur.com/NzO4l.jpg
The code:
Sub GenerateDates()
Application.ScreenUpdating = False
Dim i, j As Integer
Dim finalRow, finalRow2, startRow As Long
finalRow = Range("A" & Rows.Count).End(xlUp).Row
finalRow2 = Range("M" & Rows.Count).End(xlUp).Row
For i = 2 To 4 'finalRow
finalRow2 = Range("M" & Rows.Count).End(xlUp).Row
startRow = finalRow2 + 1
Range("M" & startRow) = Range("A" & i)
j = i
Days = Int((Range("B" & i) - Range("A" & i)))
Do While j < 2 + Days
j = j + 1
Range("M" & j) = Range("M" & j - 1) + 1
Loop
Range("N" & startRow) = Range("C" & i)
Range("O" & startRow) = ""
Range("P" & startRow) = Range("F" & i)
Range("Q" & startRow) = Range("G" & i)
Next i
End Sub
Target output sample:
https://i.stack.imgur.com/LLaO2.jpg
Resolved the conundrum myself. :-)
Sub GenerateDates()
Application.ScreenUpdating = False
Dim i, j, numDays As Integer
Dim finalRow, finalRow2 As Long
Dim startDate, endDate As Date
Dim strType, strName, strCountry As String
finalRow = Range("A" & Rows.Count).End(xlUp).Row
finalRow2 = Range("M" & Rows.Count).End(xlUp).Row
If finalRow2 > 1 Then
Range("M2:Q" & finalRow2).Select
Selection.ClearContents
End If
Range("A1").Select
For i = 2 To finalRow
startDate = Range("A" & i).Value
endDate = Range("B" & i).Value
startDate = startDate - 1
strType = Range("C" & i).Value
numDays = Range("D" & i).Value
strName = Range("F" & i).Value
strCountry = Range("G" & i).Value
Do While startDate < endDate
finalRow2 = Range("M" & Rows.Count).End(xlUp).Row
finalRow2 = finalRow2 + 1
startDate = DateAdd("d", 1, startDate)
Range("M" & finalRow2).Value = startDate
Range("N" & finalRow2).Value = strType
'Function to split decimal numDays
Range("P" & finalRow2).Value = strName
Range("Q" & finalRow2).Value = strCountry
Loop
Next i
Application.ScreenUpdating = True
End Sub
I have this code and would like it to convert it to work for chrome instead of IE:
For Each htmlEle In ieObj.Document.getElementsByClassName("data data14902")(0).getElementsByTagName("tr")
With ActiveSheet
.Range("A" & i).Value = htmlEle.Children(0).textContent
.Range("B" & i).Value = htmlEle.Children(1).textContent
.Range("C" & i).Value = htmlEle.Children(2).textContent
.Range("D" & i).Value = htmlEle.Children(3).textContent
.Range("E" & i).Value = htmlEle.Children(4).textContent
.Range("F" & i).Value = htmlEle.Children(5).textContent
.Range("G" & i).Value = htmlEle.Children(6).textContent
.Range("H" & i).Value = htmlEle.Children(7).textContent
.Range("I" & i).Value = htmlEle.Children(8).textContent
.Range("J" & i).Value = htmlEle.Children(9).textContent
.Range("K" & i).Value = htmlEle.Children(10).textContent
.Range("L" & i).Value = htmlEle.Children(11).textContent
End With
i = i + 1
Next htmlEle
This is only a chunk of the code. What I'm doing is navigating to a particular webpage with a data table and what I want to do is copy all the data and paste it into excel.
Also, if there are parts of the code that can be improved, I'm open to it!
I'm trying to modify the below function to include logic where if the variables PPD_1_Date, PPD_2_Date and TSpot_Date are all empty (blank) then output to my "Error" worksheet.
I have rows that should fall under this logic, however they are falling under the Else condition instead.
Function PPDdate()
Dim PPD_1_Date As Date
Dim PPD_2_Date As Date
Dim TSpot_Date As Variant
Dim i As Long, j As Long, k As Long
j = Worksheets("PPDCI").Range("A" & Rows.Count).End(xlUp).Row + 1
k = Worksheets("Error").Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 2 To lstrow
PPD_1_Date = Worksheets("Data").Range("AW" & i)
PPD_2_Date = Worksheets("Data").Range("BA" & i)
Entity = Worksheets("Data").Range("J" & i)
Dept = Worksheets("Data").Range("M" & i)
TSpot_Date = Worksheets("Data").Range("AS" & i)
If PPD_1_Date > PPD_2_Date Then
Worksheets("PPDCI").Range("A" & j & ":C" & j).Value = Worksheets("Data").Range("A" & i & ":C" & i).Value
Worksheets("PPDCI").Range("F" & j).Value = PPD_1_Date
Worksheets("PPDCI").Range("G" & j).Value = Worksheets("Data").Range("AX" & i).Value
Worksheets("PPDCI").Range("H" & j).Value = Worksheets("Data").Range("AZ" & i).Value
Worksheets("PPDCI").Range("I" & j).Value = Worksheets("Data").Range("AY" & i).Value
j = j + 1
Else
If PPD_1_Date < PPD_2_Date Then
Worksheets("PPDCI").Range("A" & j & ":C" & j).Value = Worksheets("Data").Range("A" & i & ":C" & i).Value
Worksheets("PPDCI").Range("F" & j).Value = PPD_2_Date
'Worksheets("PPDCI").Range("G" & j).Value = "ELSE IF CONDITION"
Worksheets("PPDCI").Range("G" & j).Value = Worksheets("Data").Range("BB" & i).Value
Worksheets("PPDCI").Range("H" & j).Value = Worksheets("Data").Range("BD" & i).Value
Worksheets("PPDCI").Range("I" & j).Value = Worksheets("Data").Range("BC" & i).Value
j = j + 1
Else
'If IsEmpty(Worksheets("Data").Range(PPD_1_Date & i).Value) = True And IsEmpty(Worksheets("Data").Range(PPD_2_Date & i).Value) = True Then
'GoTo EmptyRange
'Else
If (InStr(1, Entity, "CNG Hospital") Or InStr(1, Entity, "Home Health") Or InStr(1, Entity, "Hospice") Or InStr(1, Dept, "Volunteers") Or ((IsEmpty(PPD_1_Date) = True) And (IsEmpty(PPD_2_Date) = True))) And IsEmpty(TSpot_Date) = True Then
Worksheets("Error").Range("A" & k & ":H" & k).Value = Worksheets("Data").Range("A" & i & ":C" & i).Value
Worksheets("Error").Range("F" & k).Value = "REVIEW PPD DATA"
k = k + 1
Else
Worksheets("PPDCI").Range("A" & j & ":C" & j).Value = Worksheets("Data").Range("A" & i & ":C" & i).Value
Worksheets("PPDCI").Range("F" & j).Value = TSpot_Date
Worksheets("PPDCI").Range("G" & j).Value = Worksheets("Data").Range("AX" & i).Value
Worksheets("PPDCI").Range("H" & j).Value = Worksheets("Data").Range("AY" & i).Value
Worksheets("PPDCI").Range("I" & j).Value = "NO PPD DATES BUT HAS TSPOT DATE1"
j = j + 1
End If
End If
End If
'EmptyRange:
'k = k + 1
Next i
End Function
Here is the code I added to the other OR logic;
Or ((IsEmpty(PPD_1_Date) = True) And (IsEmpty(PPD_2_Date) = True))
Example row has empty cells in columns AW, BA, and AS, so it should write to my Error worksheet. Is there a syntax or logic issue? I did initially have TSPOT_Date defined as a Date variable, however I was getting a '1004' runtime error (I think because some column rows are empty) so I changed to Variant, however logic still doesn't work as I expect.
The problem you're running into is that you can't check if Date variables are "empty" using isEmpty() or even with Len() because the default value for a date is 30-Dec-1899 00:00:00, so there is always a value in a Date variable.
Instead, you should check to see that a Date variable is empty/has not been filled like this
If PPD_2_Date = 0 Then
...
Final One:enter image description hereI want to insert blank row with a specific column range above a particular row.
For example:
There were 2 sets of data in a single sheet ,ie, 1st set col A to Col E and 2nd set Col F to Col J. I need to compare Column Ai with Column Fi (where i indicates the position of row) and if both values are same then the comparison can be proceeded like Bi with Gi, Ci with Hi and so and so and if not, I need to shift that set of 2nd data Fi to Ji to next row..ie. if the whole set is in 6th position I need to shift them down to 7th position and make the 6th position of Fi to Ji blank....
Sub Dcompare()
Dim endRow As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
endRow = Sheet1.Range("A999999").End(xlUp).Row
For i = 2 To endRow
If Sheet1.Range("A" & i).Value = Sheet1.Range("F" & i).Value Then
Sheet1.Range("K" & i).Value = "Yes"
Else
ws.Range("F" & i & ":J" & i).Offset(1, 0).Value = ws.Range("F" & i & ":J" & i).Value
ws.Range("F" & i & ":J" & i).Value = ""
End If
Next i
For j = 2 To endRow
If Sheet1.Range("K" & j).Value = "Yes" Then
If Sheet1.Range("B" & j).Value = Sheet1.Range("G" & j).Value Then
Sheet1.Range("L" & j).Value = "Yes"
Else
Sheet1.Range("L" & j).Value = "No"
End If
If Sheet1.Range("C" & j).Value = Sheet1.Range("H" & j).Value Then
Sheet1.Range("M" & j).Value = "Yes"
Else
Sheet1.Range("M" & j).Value = "No"
End If
If Sheet1.Range("D" & j).Value = Sheet1.Range("I" & j).Value Then
Sheet1.Range("N" & j).Value = "Yes"
Else
Sheet1.Range("N" & j).Value = "No"
End If
If Sheet1.Range("E" & j).Value = Sheet1.Range("J" & j).Value Then
Sheet1.Range("O" & j).Value = "Yes"
Else
Sheet1.Range("O" & j).Value = "No"
End If
End If
Next j
End Sub
------>Final Code Inserted---------
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
For i = 2 To endRow + 1
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("K" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ws.Range("A" & i + 1 & ":E" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
endRow = endRow + 1
dShift = True
Else
dShift = False
End If
End If
j = i
If ws.Range("K" & j).Value = "Yes" Then
If ws.Range("B" & j).Value = ws.Range("G" & j).Value Then
ws.Range("L" & j).Value = "Yes"
Else
ws.Range("L" & j).Value = "No"
End If
If ws.Range("C" & j).Value = ws.Range("H" & j).Value Then
ws.Range("M" & j).Value = "Yes"
Else
ws.Range("M" & j).Value = "No"
End If
If ws.Range("D" & j).Value = ws.Range("I" & j).Value Then
ws.Range("N" & j).Value = "Yes"
Else
ws.Range("N" & j).Value = "No"
End If
If ws.Range("E" & j).Value = ws.Range("J" & j).Value Then
ws.Range("O" & j).Value = "Yes"
Else
ws.Range("O" & j).Value = "No"
End If
Else
End If
Next i
MsgBox "The value of endRow is : " & endRow, vbInformation
End Sub
Based on your explanations, this is what I interpret your challenge as:
Evaluate Ai with Fi --> Ei with Ji from left to right, and indicate in helper-columns whether the evaluation succeeded or not
If the first evaluation is Not Equal, offset the range Fi:Ji downwards exactly one row
If a range has been shifted down, the loop should evaluate this line but never shift it again regardless of outcome of the evaluation
This code satisfies those conditions (change i and other row variables to your needs):
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
' Set initial value of helper columns to no - saves miniscule time and complexity in the loop
ws.Range("L" & 1 & ":O" & endRow).Value = "No"
For i = 1 To endRow
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("L" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' Remember that we just shifted a row
dShift = True
Else
' Reset shift counter
dShift = False
End If
End If
For j = 2 To 4
If dShift Then Exit For
If ws.Cells(i, j).Value = ws.Cells(i, j + 5).Value Then ws.Cells(i, j + 11).Value = "Yes"
Next j
Next i
End Sub
However, it seems strange to me that you would want this functionality? Please confirm that it is correct. The behavior it yields in the worksheet is very strange.
Let me show with images. Orange background means the code will show the cell as a match. Green background means the code will show that the cell doesn't match.
Before the code it looks like this:
After the code it looks like this:
I have been trying to run the same Do While loop function across multiple worksheets in a workbook and compile the data in another worksheet. The code works for the one worksheet that is specified but how do I get it to work across the others that are in the workbook at the same time?
Also worth mentioning that I only want it to run on some of the worksheets not all that are in the workbook (sheets are named as years - 2014, 2015 etc).
This is the code
Sub Total_Button1_Click()
Dim i As Integer
Dim strSheetFrom As String
Dim j As Integer
Dim strSheetTo As String
i = 3
j = 2
strSheetFrom = "2014"
strSheetTo = "Total"
Do While Trim(Sheets(strSheetTo).Range("B" & CStr(j)).Text) <> ""
j = j + 2
Loop
Do While Trim(Sheets(strSheetFrom).Range("B" & CStr(i)).Text) <> ""
If UCase(Trim(Sheets(strSheetFrom).Range("A" & CStr(i)).Text)) = "Y" Then
Sheets(strSheetTo).Range("B" & j & ":G" & j).Value = Sheets(strSheetFrom).Range("B" & i & ":G" & i).Value
Sheets(strSheetTo).Range("H" & j & ":I" & j).Value = Sheets(strSheetFrom).Range("I" & i & ":J" & i).Value
Sheets(strSheetTo).Range("J" & j & ":J" & j).Value = Sheets(strSheetFrom).Range("L" & i & ":L" & i).Value
Sheets(strSheetTo).Range("K" & j & ":K" & j).Value = Sheets(strSheetFrom).Range("Q" & i & ":Q" & i).Value
Sheets(strSheetTo).Range("L" & j & ":AH" & j).Value = Sheets(strSheetFrom).Range("s" & i & ":AO" & i).Value
j = j + 1
End If
i = i + 1
Loop
MsgBox "Total book created"
End Sub
Try making your strSheetFrom variable an array something like this:
strSheetFrom = new strSheetFrom[3]
strSheetFrom[2] = "2012"
strSheetFrom[1] = "2013"
strSheetFrom[0] = "2014"
Then put your code into another loop like so:
dim w as integer
for w = 0 To 3
Do While Trim(Sheets(strSheetTo).Range("B" & CStr(j)).Text) <> ""
j = j + 2
Loop
Do While Trim(Sheets(strSheetFrom[w]).Range("B" & CStr(i)).Text) <> ""
If UCase(Trim(Sheets(strSheetFrom[w]).Range("A" & CStr(i)).Text)) = "Y" Then
Sheets(strSheetTo).Range("B" & j & ":G" & j).Value = Sheets(strSheetFrom[w]).Range("B" & i & ":G" & i).Value
Sheets(strSheetTo).Range("H" & j & ":I" & j).Value = Sheets(strSheetFrom[w]).Range("I" & i & ":J" & i).Value
Sheets(strSheetTo).Range("J" & j & ":J" & j).Value = Sheets(strSheetFrom[w]).Range("L" & i & ":L" & i).Value
Sheets(strSheetTo).Range("K" & j & ":K" & j).Value = Sheets(strSheetFrom[w]).Range("Q" & i & ":Q" & i).Value
Sheets(strSheetTo).Range("L" & j & ":AH" & j).Value = Sheets(strSheetFrom[w]).Range("s" & i & ":AO" & i).Value
j = j + 1
End If
i = i + 1
Loop
w -= 1
next
I haven't tested it, but something like that. You get the idea.
Use a For Each and iterate over the Worksheet collections like this
'Variables
Dim useWorkSheet As Worksheet
Dim totalWorkSheet As Worksheet
Dim yearAsNumeric As Integer
Dim startingYear As Integer
'Settings
startingYear = 2014
'To reference the total worksheet so we can work with it
Set totalWorkSheet = ActiveWorkbook.Worksheets("Total")
'Iterate over each item in the collection
For Each useWorkSheet In ActiveWorkbook.Worksheets
'Force the name into a numeric value. If it starts with anything non numeric (A-Z|a-z|$,#,etc) then it will return 0
yearAsNumeric = Val(useWorkSheet.Name)
'Greater than or equal to the year we want to start with?
If yearAsNumeric >= startingYear Then
'Yes. Do your stuff here
useWorkSheet.Name
End If
Next