Facing such a problem when hadling with excels again...
I have an excel table with such cloumns
People Date
-------------------------
A 01/01/2013 - 05/01/2013
B 03/05/2013
C 08/06/2013
What I want to produce (For example A)
People Individual Date
-------------------------
A 01/01/2013
A 02/01/2013
A 03/01/2013
A 04/01/2013
A 05/01/2013
The year will be constant at 2013 and month are more or less kept constant as well.
Can someone give idea on how to achieve this?
Sub ExpandDates()
Dim rCell As Range
Dim i As Long
Dim vaDates As Variant
Dim rNext As Range
'Loop through the cells that contain dates or date ranges
For Each rCell In Sheet1.Range("B2:B4").Cells
'If there's a space, hyphen, space in the cell, it's a date range
If InStr(1, rCell.Value, " - ") > 0 Then
'Split the cell contents on space, hyphen, space
vaDates = Split(rCell.Value, " - ")
'Loop through the days of the range of dates
For i = CDate(vaDates(0)) To CDate(vaDates(1))
'Find the next blank cell in column E to record the results
Set rNext = Sheet1.Cells(Sheet1.Rows.Count, 5).End(xlUp).Offset(1, 0)
'Write column A to column E
rNext.Value = rCell.Offset(0, -1).Value
'Create a new date in column B using the month that the loop is currently processing
rNext.Offset(0, 1).Value = CDate(i)
Next i
'If no hyphen, it's just a date, so create one line in column E
Else
Set rNext = Sheet1.Cells(Sheet1.Rows.Count, 5).End(xlUp).Offset(1, 0)
rNext.Value = rCell.Offset(0, -1).Value
rNext.Offset(0, 1).Value = rCell.Value
End If
Next rCell
End Sub
Theory: Check the length of the cell. If the cell is longer than 10 characters, use the SPLIT function to get the 2 dates. Set the months equal to a variable, and do a loop based on those months to calculate the dates between them. You would probably store those dates in an array. Then write the array to the spreadsheet and move to the next cell to start the process over.
EDIT:
Sub prSplit()
If len(ActiveCell.Value) > 10 Then
Dim arr() As String
arr = Trim(Split(ActiveCell.Value, "-"))
For i = LBound(arr) To UBound(arr)
MsgBox arr(i)
Next
End If
End Sub
You can start with this and tweak the code until you get it. I just don't have the time to do the whole thing. Sorry. :o(
Related
I am trying to figure out how to add some cell values together from different sheets but I don't know what the cells references are as they vary!
Basically the values i need will appear 2 rows below some certain text. So I was looking for a formula that searches multiple sheets, finds the specific text, goes 2 rows below then adds the values together.
Here's something I hope you can adapt to your situation by changing the sheet and row and column range, the text to look for, and the destination of the total.
Sub findfvalues()
Dim rowValue
Dim total
total = 0
For r = 1 To 25 'update this to suit your needs
For c = 1 To 25 'update this to suit your needs
If Cells(r, c).Value = "f" Then 'update "f" to search for what you want
rowValue = r + 2
total = total + Cells(rowValue, c).Value
End If
Next
Next
Cells(30, 1).Value = total 'update this to suit your needs
End Sub
So we just check every cell for the "f" and if we find it, we add the value to a running total. Display the total at the end.
This will look in each worksheet, and if your text is found, add the value that's two rows below to a running total:
Sub find_Values()
Dim ws As Worksheet
Dim findStr As String
Dim foundCell As Range
Dim total As Long
findStr = "my Text"
For Each ws In ActiveWorkbook.Worksheets
Set foundCell = ws.Cells.Find(what:=findStr)
If Not foundCell Is Nothing Then
total = total + foundCell.Offset(2, 0).Value
End If
Next ws
Debug.Print "The value is: " & total
End Sub
I have a vba-created speadsheet with 4 sets of criteria. I need to highlight names at the bottom of the sheet based on whether or not they meet all the criteria.
I need the name to highlight if the analyst took 91 minutes or less of total break (B3:F9) each day, 15 minutes or less of tea break (B12:F18), and made at least 3 outbound calls each day (provided the staff time was 8 hours and 58 minutes or more (if it wasn't, the 3 call threshold does not apply)).
So, a function would be something like:
If
TtlB<91 mins & TeaB<15
& If
StfT <8:58:00 ignore ObC
Else If
StfT >8:58:00 & ObC>=3
Highlight (analyst name in A22:A28)
I know it will probably involve a nested loop or two, I just don't know where to get started. The loop for calculating "Total Minutes Owed" is below which can probably be modified to help me get started with this.
Dim i As Integer, j As Integer, k As Integer
j = 3
k = 12
For i = 22 To 28
Range("B" & i) = "=SUM(G" & j & ",G" & k & ")"
j = j + 1
k = k + 1
Next i
I'm pretty shure that a much more compact code can be done. But, since nobody answer you in the last four hours, try the following at least as an start.
Private Sub CommandButton1_Click()
Dim oWs As Worksheet
Dim rAnalysts As Range
Dim rBreak As Range
Dim rObC As Range
Dim rTea As Range
Dim rST As Range
Dim rRow As Range
Dim rIntersection As Range
Dim rCell As Range
Set oWs = Worksheets("MyData") 'The worksheet where data resides
MaxBreakTime = oWs.Cells(1, 7).Value 'The max break time. I set it in cell G1. Change according to your needs
Set rAnalysts = oWs.Rows("3:9") 'Define the rows for analysts
Set rBreak = oWs.Range("B:F") 'define the columns where Break data is placed
'(similarly, set ranges for tea break, etc)
For Each rRow In rAnalysts.Rows 'for each row in the analyst range
sAnalystName = oWs.Cells(rRow.Row, 1).Value 'get the name of the analyst
lBreakTime = 0 'restart this variable to zero
Set rIntersection = Application.Intersect(rRow, rBreak) ' intersect the row (the analyst) with the columns of the Break range
If rIntersection Is Nothing Then
MsgBox "Ranges do not intersect. Something is radically wrong."
Else
For Each rCell In rIntersection.Cells 'id est, friday through thursday
If rCell.Value > MaxBreakTime Then 'if break was longer that stipulated,....
lBreakTime = lBreakTime + rCell.Value - MaxBreakTime 'add the excess to the variable
End If
Next
End If
'write data somewhere (here, 30 rows down from original Analysts range)
oWs.Cells(rRow.Row + 30, 1) = sAnalystName
oWs.Cells(rRow.Row + 30, 2) = lBreakTime
If lBreakTime > 0 Then
oWs.Cells(rRow.Row + 30, 2).Font.Color = vbGreen
oWs.Cells(rRow.Row + 30, 2).Interior.Color = vbRed
End If
Next
'Here something similar for Tea break and Outbounds calls
'Since output is already writen, you can reuse variables like rIntersection or rCell
End Sub
I've got a column: U. This column has values from U10 till U500.
What I need to get is the last changing value of the column and if it doesn't change then a text "False" or something and if the last changing value is an empty cell, then ignore that..
Column U
11
11
5
11
11
21
For example here the result should be 21.
I've tried comparing two rows and with conditional formatting but with such a big range doing all this for each row is a bit too much.
Does anybody know a good way to do this?
Something like that should do it ...
Sub test()
Dim LastRow As Long, i As Long
With Worksheets("Sheet1") 'your sheet name
LastRow = .Cells(.Rows.Count, "U").End(xlUp).Row 'find last used row in column U
For i = LastRow To 2 Step -1 'loop from last row to row 2 backwards (row 1 can not be compared with row before)
If .Cells(i, "U").Value <> .Cells(i - 1, "U").Value Then 'compare row i with row before. If it changes then ...
MsgBox "Last row is: " & .Cells(i, "U").Address & vbCrLf & _
"Value is: " & .Cells(i, "U").Value
Exit For 'stop if last changing row is found
End If
Next i
End With
End Sub
It loops from last used row in column U to the first row and checks if the current row is different from the row before. If so it stops.
i am not sure of the how you want the output.
IF(AND(RC[-1]<>R[-1]C[-1],ROW(RC[-1])>500,R[-1]C[-1]<>""),RC[-1],"")
try this formula in cells V10:V500
Try this Macro.
First run the AnalyseBefore sub and when you want to check if the value has changed run the AfterAnalyse sub.
Incase you want the range to be dynamic use the code that I have commented and include iCount in your Range calculation
Sub AnalyseBefore()
Dim iCount
Range("U10").Select
iOvalue = Range("U500").Value
'iCount = Selection.Rows.Count
Range("Z1").Value = iOvalue
End Sub
Sub AnalyseAfter()
Dim iCount
Range("U10").Select
iNValue = Range("U500").Value
Range("Z2").Value = iNValue
iOvalue = Range("Z1").Value
If (iOvalue = iNValue) Then
Range("U500").Value = "FALSE"
End If
End Sub
I have the following column (1):
1
15
150
1500000
06700
07290
07500
2
22
220
2200000
00900
This would need to become 2 columns
1
15
150
1500000 06700
1500000 07290
1500000 07500
2
22
220
2200000 00900
My initial idea:
Create the extra column.
Looping through the rows, register the cell and value in variables when a number with lenght of 7 digits is found.
Move the values under it to column B until the lenght of values is <> 5
Start from cell saved in variable and copy value from variable to column A until column A is no longer Empty
After the above proces, loop rows and delete where A is lenght 7 and B is empty.
As i am not familiar with VBA, before i plunge into, i would like to verify this above set of rules would do what i intend it to do, if it's technically feasable with VBA macro's and wether or not it could result to unexpected behaviour.
This code would have to run every month on a new large excel file.
Whether your 5 digit (c/w/ leading zeroes) numbers are true numbers with a cell formatting of 00000 or text-that-look-like-numbers with a Range.PrefixCharacter property, the Range.Text property should be able to determine their trimmed length from the displayed text.
The following code follows your logic steps with a few modifications; the most obvious one is that it walks from the bottom of column A to the top. This is to avoid skipping rows that have been deleted.
Sub bringOver()
Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant
'put the cursor anywhere in here and start tapping F8
'it will help if you can also see the worksheet with your
'sample data
ReDim vVAL5s(0) 'preset some space for the first value
With Worksheets("Sheet1") '<~~ set this worksheet reference properly!
'ensure a blank column B
.Columns(2).Insert
'work from the bottom to the top when deleting rows
'or you risk skipping a row
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'determine the length of the trimmed displayed length
'and act accordingly
Select Case Len(Trim(.Cells(rw, 1).Text))
Case Is < 5
'do nothing
Case 5
'it's one to be transferred; collect it
vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text
'make room for the next
ReDim Preserve vVAL5s(UBound(vVAL5s) + 1)
Case 7
'only process the transfer if there is something to transfer
If CBool(UBound(vVAL5s)) Then
'the array was built from the bottom to the top
'so reverse the order in the array
ReDim vREV5s(UBound(vVAL5s) - 1)
For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1
vREV5s(UBound(vREV5s) - v) = vVAL5s(v)
Next v
'working With Cells is like selecting htem but without selecting them
'want to work With a group of cells tall enough for all the collected values
With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1)
'move over to column B and put the values in
.Offset(0, 1) = Application.Transpose(vREV5s)
'make sure they show leading zeroes
.Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]#"
'if there was more than 1 moved over, FillDown the 7-wide value
If CBool(UBound(vREV5s)) Then .FillDown
'delete the last row
.Cells(.Rows.Count + 1, 1).EntireRow.Delete
End With
'reset the array for the next first value
ReDim vVAL5s(0)
End If
Case Else
'do nothing
End Select
'move to the next row up and continue
Next rw
'covert the formatted numbers to text
Call makeText(.Columns(2))
End With
End Sub
Sub makeText(rng As Range)
Dim tCell As Range
For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers)
tCell.Value = Format(tCell.Value2, "\'00000;#")
Next tCell
End Sub
Just before exiting the primary routine, the short helper sub is called using column B as a range of cells. This will loop through all of the numbers in column B and convert the numbers into text with leading zeroes.
As noted in the code comments, set yourself up so you can see the code sheet as well as a portion of your worksheet and start tapping F8 to step through the code. I've tried to add a form of running commentary with the notes left above many of the code lines.
After writing the logic keeping in mind Jeeped's input i ended up making it the following way:
Force convert the column A to definately be Text
Create the extra column.
Get the number of rows with data
Loop 1: If column A cell lenght is 5, move cell to column B
Loop 2: If column A cell lenght is 7, we copy the value to variable.
Loop 2: If column A cell lenght is 0, we paste variable to the cell
After the above proces, loop rows and delete where A is lenght 7 and B is empty. (reverse loop for performance)
All input on the below posted code is more than welcome. I'm open for every kind of possible optimization.
Sub FixCols()
'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim
Range("A:A").NumberFormat = "#"
Dim Cell As Range
For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells
x = x + 1
Cell = Trim(Cell)
Cell.Value = WorksheetFunction.Trim(Cell.Value)
Next
'Now insert empty column as B
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Determine rows with values for loop
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Loops to move around the data
Dim i As Long
Dim CellValue As Long
For i = 1 To LastRow
'move items to column B
If Len(Range("A" & i).Value) = 5 Then
Range("A" & i).Select
Selection.Cut
Range("B" & i).Select
ActiveSheet.Paste
End If
Next i
For i = 1 To LastRow
'if the row is a reknr we copy the value
If Len(Range("A" & i).Value) = 7 Then
CellValue = Range("A" & i).Value
End If
'Paste the reknr to the rows with item
If Len(Range("A" & i).Value) = 0 Then
Range("A" & i).Value = CellValue
End If
Next i
'Reverse loop (performance) to check for rows to delete (reknr without item)
i = LastRow
Do
If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then
Rows(i).Delete
End If
i = i - 1
Loop While Not i < 1
End Sub
Sub UpdateCSAH()
Dim S As String
Dim R As Long
Dim RR As Long
Dim CC As Long
Dim i As Long
Dim j As Long
Dim csah() As String 'an array that stores the CSAH sites
ReDim csah(1 To 100, 1 To 7)
Dim Ran As Range
Dim Ran1 As Range
Set Ran = Worksheets("Current Sites").Range("A1").CurrentRegion 'Ran is the region that has values
RR = 1 'row number in csah
CC = 1 'column number in csah
'check each value in Ran to see if its Route section has "CSAH"
For Each cell In Ran
R = cell.row
S = CStr(Cells(R, 4).value)
If InStr(S, "CSAH") > 0 Then 'check if "CSAH" is in the Route section
If CC > 7 Then 'reset the column number and go to the next row when reach the end of the column
CC = 1
RR = RR + 1
End If
csah(RR, CC) = cell.value
CC = CC + 1
End If
Next cell
Worksheets("CSAH Sites").Select
Range("A2:G100").Select
Selection.ClearContents
'assign each array values to cells in sheet"CSAH Sites"
i = 1
j = 1
For i = 1 To UBound(csah, 1)
For j = 1 To UBound(csah, 2)
Cells(i + 1, j) = csah(i, j)
Next j
Next i
'format the CSAH Sites values
Set Ran1 = Worksheets("CSAH Sites").Range("A1").CurrentRegion
For Each cell In Ran1
If cell.row = 1 Then
With cell.Font
.Color = -11489280
End With
ElseIf cell.row Mod 2 = 0 Then
With cell.Interior
.Color = 10092441
End With
End If
Next cell
End Sub
I have an Excel worksheet named "Current Sites" that has some data. If the 4th column has the word "CSAH", I want to store the values of that row into an array and assign those values to cells in the worksheet named "CSAH Sites". My code sometimes works (the 1st time you click), and most of times it doesn't work or doesn't work properly.
Please help me out! Thanks A Bunch!!
It looks like you want to check every row of data in the "Current Sites" sheet and if column 4 includes the "CSAH" text, then write the first 7 columns of data for that entry to the "CSAH Sites" sheet and add some colour to the even-numbered rows.
To check every row of data, you can read down just one column and use either the Offset or the Cells method to see the values of neighbouring cells. In your code you were "touching" every cell and each time you were then looking at the value in column 4 and also checking to see if the code had gone past column 7. That slows things down a lot and makes the code hard to understand.
You can also assign the values from a range of cells directly to another range of cells without using variables or an array.
See if this does what you want:
Sub UpdateCSAH()
Dim currentSitesRange As Range
Dim thisSiteRange As Range
Dim outputCell As Range
Dim numRowsOfData As Long
Const NUM_COLUMNS_OF_DATA As Integer = 7
Set currentSitesRange = Worksheets("Current Sites").Range("A1")
numRowsOfData = currentSitesRange.CurrentRegion.Rows.Count
Set currentSitesRange = currentSitesRange.Resize(RowSize:=numRowsOfData) 'currentSitesRange is the region that has values
Worksheets("CSAH Sites").Range("A2:G100").ClearContents
Set outputCell = Worksheets("CSAH Sites").Range("A2")
For Each thisSiteRange In currentSitesRange.Cells
' Look for "CSAH" in the Route section (column D)
If InStr(1, thisSiteRange.Offset(ColumnOffset:=3).Value, "CSAH", vbTextCompare) > 0 Then
' Found "CSAH" so write NUM_COLUMNS_OF_DATA columns of data to CSAH Sites sheet
outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value = thisSiteRange.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value
' Format the even-numbered rows
If outputCell.Row Mod 2 = 0 Then
With outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Interior
.Color = 10092441
End With
End If
Set outputCell = outputCell.Offset(RowOffset:=1)
End If
Next thisSiteRange
End Sub