I have a data set of 24 hours of demand (rows) by 365 days (columns) and I need to convert this to one continuous vertical data series. In other words create a macro that copies the second day's data and pastes it below the first and so on through the balance of the year.
I found an answer from Manji that is related (I think..) but I am not experienced enough to adapt this code to what I need. Can someone please point me in the right direction?
Here's what I'm looking at:
Sub Macro1()
'
' Macro1 Macro
'
'
Dim oRange As range
Dim startColumn As String
Dim rangestart As Integer
Dim rangeEnd As Integer
Dim cellcount As Integer
Dim i As Integer
startColumn = "A"
rangestart = 1
rangeEnd = 24
cellcount = rangeEnd - rangestart + 1
For i = 1 To cellcount - 1
Set oRange = ActiveSheet.range(startColumn & rangestart & ":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.range(startColumn & (rangeEnd - i + 1) & ":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellcount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
I think something like this might help:
Sub DayHour()
Dim r As Long, c As Long, startRow As Long, hoursColumn As Long
Dim daysRow As Long, i As Long, j As Long
daysRow = 1 ' this is the row where 'day 1', 'day 2' (or similar) is written
hoursColumn = 1 ' this is the column where 'hour 1', 'hour 2' (or similar) is written
r = Cells(Rows.Count, hoursColumn).End(xlUp).Row
c = Cells(daysRow, Columns.Count).End(xlToLeft).Column
For i = daysRow To r
For j = hoursColumn To c
With Sheets(2)
.Cells(j, i) = Cells(i, j)
End With
Next j
Next i
End Sub
It writes the rearranged values in sheet 2 of the excel file. I think that's more or less, what you need. If you don't understand something or this isn't what you wanted, just leave a comment.
Little note: copy&paste in most cases isn't a good solution in VBA.
Edit: Something else came into my mind. You don't have to do that in VBA. Excel has a built-in function to do that.
Here is the explanation:
Select all of your data and press Ctrl+C (important: not right click and copy). Then you go to the area where you want your data to be placed. (note: shouldn't be the same place from where you copied the data)
Now do a right click on the cell and press on Past Special... Activate Transpose and click Ok. The data should be in place now.
Related
I have data that I'm moving into a template, and I'm trying to repurpose my vba script I used. Before, the data needed to be transposed into a specific range, but now I want to just move it over without the need to transpose it.
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
I assume the dest.offset property is what is causing the transposition, how would I change this to just move the array normally without the transpose?
Rest of script:
Option Explicit
Sub Main()
Dim Wb As Workbook
Dim Data, Last
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set Wb = Workbooks("ValidationTemplate.xlsx")
'Refer to the destination cell
Set Dest = Wb.Sheets("Employee Core Skills").Range("B3")
'Read in all data
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("DO2", .Range("A" & Rows.Count).End(xlUp))
End With
Wb.Activate
Application.ScreenUpdating = False
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & "_Assessment.xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
End If
'Next column
j = j + 1
Next
End Sub
If I understand your question correctly...
Dest.Offset(a, j)
Means use the Range referred to by the Range Object called Dest, then offset from there a rows (positive would be down the spreadsheet, negative up the spreadsheet) and j columns (positive to the right, negative to the left).
If you just want to put the data in the Range pointed to by Dest, then simply omit the .Offset() portion like this:
Dest.value2 = Data(i,k).value2
Note: .Value is the default member referred to when you leave it off by referring to just Dest. It's always best to specify and not leave it up to VBA to figure out what you mean. Why use .Value2 instead of just .Value? Read this SO question and the accepted answer.
The transposition is happening here because of the order of a and j.
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
End If
'Next column
j = j + 1
It's really hard to tell because of the unclear variable names.
If you rename your variables like this:
Dim I as Long --> Dim sourceRow as Long
Dim K as Long --> Dim sourceCol as Long
Dim A as Long --> Dim destRow as Long
Dim J as Long --> Dim destCol as Long
You'll see that's the way they're being currently being used and that what you want to do is swap destRow with destCol.
Rewriting that code with the new variable names gives you:
destRow = 0
For sourceCol = 2 To UBound(Data, 2)
Dest.Offset(destRow, destCol) = Data(sourceRow, sourceCol)
destRow = destRow + 1
Next
End If
'Next column
destCol = destCol + 1
and now you can much more easily see that your loop is incrementing your sourceCol and your destRow. If you now change that to:
destRow = 0
For sourceCol = 2 To UBound(Data, 2)
Dest.Offset(destRow, destCol).Value2 = Data(sourceRow, sourceCol).Value2
destCol = destCol + 1
Next
End If
'Next column
destRow = destRow + 1
You'll see that the loop is now incrementing both source & dest columns. Now you just need to change the incrementers in the outer loop to update the rows in sync and you should be good.
This is a great object lesson in why good names for code "things" are incredibly valuable. Once I sorted out a, i, j & k, it made it very obvious. It appears you're not the original author of this code, but even if you are, it's OK. Most of us start out with horrible names for stuff then slowly learn over time how valuable good names are. It's well worth it to refactor the code to improve these names and others.
A quick shameless plug for the Rubberduck plugin for the VBE. I'm a huge fan and starting to contribute to the project, as well. It will allow you to refactor your code by intelligently renaming variables. As you can imagine, doing a search & replace for i to sourceRow wsourceRowll gsourceRowve you some sersourceRowously broken code! Rubberduck will avoid that problem and add many, many more features that you'll soon wonder how you ever lived without!
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
So I'm hoping for some help to automate a process that will otherwise involve copying and editing some 10,000 rows.
This is stuff relating to location data. Essentially, there are tons of these Master Rows but they do not have individual rows for Unit Numbers. I am hoping to get something to expand these into individual Unit Number rows based on what is in Column N. Column N is intended to follow a strict format of being a comma-seperated single cell list for each row.
Below is an example from Sheet 1 of what each row will have and needs to be expanded upon. Note that Column N is green and follows a consistent formatting and this will be the determinant for how many times these rows will each be expanded upon.
Below is Sheet 2 and what I want the VBA to create from Sheet 1. You can see that each row has been expanded based on the contents of Column N from Sheet 1.
Like I said, it is expected that this will involve some several thousand rows to create.
Option Explicit
Sub Tester()
Dim sht1, sht2, rwSrc As Range, rwDest As Range, v, arr, n
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
sht2.Range("A2:M2").Resize(3, 13).Value = sht1.Range("A2:M2").Value
Set rwDest = sht2.Range("A2:M2") 'destination start row
Set rwSrc = sht1.Range("A2:M2") 'source row
Do While Application.CountA(rwSrc) > 0
v = rwSrc.EntireRow.Cells(1, "N").Value 'list of values
If InStr(v, ",") > 0 Then
'list of values: split and count
arr = Split(v, ",")
n = UBound(arr) + 1
Else
'one or no value
arr = Array(v)
n = 1
End If
'duplicate source row as required
rwDest.Resize(n, 13).Value = rwSrc.Value
'copy over the unit values
rwDest.Cells(1, "G").Resize(n, 1).Value = Application.Transpose(arr)
'offset to next destination row
Set rwDest = rwDest.Offset(n, 0)
'next source row
Set rwSrc = rwSrc.Offset(1, 0)
Loop
End Sub
This does the work in same sheet... Pls copy the value to "Sheet2" before executing this. Not sure about efficiency though.
Public Sub Test()
Dim lr As Long ' To store the last row of the data range
Dim counter As Long
Dim Str As String ' To store the string in column N
lr = Range("N65536").End(xlUp).Row 'Getting the last row of the data
For i = lr To 2 Step -1
Str = Range("N" & i).Value ' Getting the value from Column N
counter = 1
For Each s In Split(Str, ",")
If counter > 1 Then
Range("A" & (i + counter - 1)).EntireRow.Insert ' Inserting rows for each value in column N
Range("G" & (i + counter - 1)).Formula = s ' Updating the value in Column G
Else
Range("G" & i).Formula = s ' No need to insert a new row for first value
End If
counter = counter + 1
Next s
Next i
lr = Range("G65536").End(xlUp).Row
' Pulling down other values from the first value row other rows
Range("A1:N" & lr).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
' Pasting the data as Values to avoid future formula issues.
Range("A1:N" & lr).Copy
Range("A1:N" & lr).PasteSpecial xlPasteValues
MsgBox "Done"
End Sub
I have a column with nearly 100k and am trying to determine how many times a value occurs repeatedly in that column. I can do it row by row currently, but this is menial as a programmer, through something like =COUNTIF(D:D,D2). Yet that only returns D2 matches in column D.
I need to iterate through all values of D returning countif, therefore revealing all of the values repetitions in the column. I can remove duplicates later! So I have a dev. button a basic sub, or function (man this is new to me) and something along the lines of the most basic for loop ever. Just getting caught up on how to implement the COUNTIF() to to the loop properly.
Right now I'm looking at:
Sub doloop()
Dim i As Integer
i = 1
Do While i < D.Length
Cells(i, 8).Value =CountIf(D:D,D[i])
i = i + 1
Loop
End Sub
That code is incorrect obviously but it is where I'm at and may help for anyone more familiar with other languages.
Use Application.WorksheetFunction.CountIf() in your loop.
Private Sub doloop()
Dim lastRow As Long
Dim d As Double
Dim r As Range
Dim WS As Excel.Worksheet
Dim strValue As String
Dim lRow As Long
'Build your worksheet object
Set WS = ActiveWorkbook.Sheets("sheet1")
'Get the last used row in column A
lastRow = WS.Cells(WS.Rows.count, "D").End(xlUp).Row
'Build your range object to be searched
Set r = WS.Range("D1:D" & lastRow)
lRow = 1
WS.Activate
'Loop through the rows and do the search
Do While lRow <= lastRow
'First, get the value we will search for from the current row
strValue = WS.Range("D" & lRow).Value
'Return the count from the CountIf() worksheet function
d = Application.worksheetFunction.CountIf(r, strValue)
'Write that value to the current row
WS.Range("H" & lRow).Value = d
lRow = lRow + 1
Loop
End Sub
I believe you are trying to write the value to the cell, that is what the above does. FYI, if you want to put a formula into the cell, here is how that is done. Use this in place of WS.Range("H" & lRow).Value = d
WS.Range("H" & lRow).Formula = "=CountIf(D:D, D" & lRow & ")"
Sounds like you may want to look into using tables in Excel and capitalizing on their features like filtering and equation autofill. You may also be interested in using a PivotTable to do something very similar to what you're describing.
If you really want to go about this the programmatic way, I think the solution Matt gives answers your question about how to do this using CountIf. There's a big detriment to using CountIf though, in that it's not very computationally efficient. I don't think the code Matt posted will really be practical for processing the 100K rows mentioned in the OP (Application.ScreenUpdating = false would help some). Here's an alternative method that's a lot more efficient, but less intuitive, so you'll have to decide what suites your needs and what you feel conformable with.
Sub CountOccurances()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("E1:E100000")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Overwrite original array values with count of that value
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next
'Write resulting array to output range
ROutput = A
End Sub
You can also modify this to include the removal of replicates you mentioned.
Sub CountOccurances_PrintOnce()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("F1:F9")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Print results to VBA's immediate window
Dim sum As Double
For Each K In d.Keys
Debug.Print K & ": " & d(K)
sum = sum + d(K)
Next
Debug.Print "Total: " & sum
End Sub
Please excuse my ignorance. I'm not an absolute programming beginner, but have little to no familiarity with VBA and the process of creating excel macros.
I have a table of data with values cyclically going up and down. What I'd like to do is hide a row if it is not a local maximum, so I can assess the trend from maximum to maximum. I've attempted to adapt another macro I found, which hides based on non-highlighting, and can't seem to get it just right.
Some things I know need changing:
1) I know I should not use"activesheet", substituting instead the actual name of the sheet in question.
2) I believe this program steps through every cell that has information in it. I only need to search through column "c". This should speed things up significantly (there are 11 other columns that I'm not interested in searching through).
3) I'm defining a local maximum as "cell Ci is a local maximum if C(i-1)C(i+1)". This causes problems when there are two cells in a row with the peak value for that local maximum. Is there a way around this? I think more than one cell per local maximum could be selected if I tried "average(x-1,x-2)average(x+1,x+2)"
4) I tried to redesign this code from someone else's code to hide rows based on not being highlighted. There are likely some bits that are unneeded and I'm too inexperienced to see them.
5) I'm searching through upwards of 15k-20k rows, because it's the output of a testing machine. I'm eager to implement any possible methods to speed this puppy up.
Here's the current code I'm trying (and thank you, thank you, thank you for your help!):
Public Sub HideUncoloredRows()
Dim startColumn As Integer
Dim startRow As Integer
Dim totalRows As Integer
Dim totalColumns As Integer
Dim currentColumn As Integer
Dim currentRow As Integer
Dim shouldHideRow As Integer
startColumn = 1 'column A
startRow = 1 'row 1
totalRows = ActiveSheet.Cells(Rows.Count, startColumn).End(xlUp).Row
For currentRow = totalRows To startRow Step -1
shouldHideRow = True
totalColumns = ActiveSheet.Cells(currentRow, Columns.Count).End(xlToLeft).Column
'for each column in the current row, check for maximum
For currentColumn = startColumn To totalColumns
'if a local maximum is found, don't hide the row and move on to next row
If ActiveSheet.Cells(currentRow, currentColumn) > ActiveSheet.Cells(currentRow-1, currentColumn) and ActiveSheet.Cells(currentRow, currentColumn) > ActiveSheet.Cells(currentRow+1, currentColumn) Then
shouldHideRow = False
Exit For
End If
Next
If shouldHideRow Then
'drop into here if there was not a local maximum
ActiveSheet.Cells(currentRow, currentColumn).EntireRow.Hidden = True
End If
Next
End Sub
Edit: By local maximum, I mean that my graph is vaguely sinusoidal in nature, and I want to track the change in magnitude from peak to peak. The result is quite similar to this graph: http://steve.vbboys.com/blog/wp-content/uploads/2008/03/dampedsin.jpg
Edit 2: Here's a made up set of data. The macro should not hide rows 3, 7, 13 and 14, and should hide all the other rows. https://www.dropbox.com/s/878e02uvb38edhd/Local%20Maxima.xlsx
I don't know if I full understand what your asking because I don't know what you mean by local maximum, but to answer your question on how to make it step through each cell in column C more efficiently you can use a Do While loop like this.
Sub Macro1()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
K = 2 'Row 1 is a header so i start on row 2
Do While ws.Cells(K, 3) <> ""
'Code
K = K + 1
Loop
End Sub
Modified on 3/4. Note I have commented out code which is not needed; you don't need to loop through columns since you only care about "C"; Don't loop to row 1; Don't need the extra code ''If shouldHideRow Then' if you change the comparison from '>' to '<' Can you update your question to provide some sample data (actual numbers, and if it should be hidden) so we know what you want to do?
Option Explicit
Public Sub HideUncoloredRows()
Dim startColumn As Integer
Dim startRow As Integer
Dim totalRows As Integer
Dim totalColumns As Integer
Dim currentColumn As Integer
Dim currentRow As Integer
Dim shouldHideRow As Integer
startColumn = 3 'column C
startRow = 1 'row 1
totalRows = ActiveSheet.Cells(Rows.Count, startColumn).End(xlUp).Row
For currentRow = totalRows To startRow + 1 Step -1 ' 3/4 - Added +1
shouldHideRow = True
'totalColumns = ActiveSheet.Cells(currentRow, Columns.Count).End(xlToLeft).Column
'for each column in the current row, check for maximum
'For currentColumn = startColumn To totalColumns
'if a local maximum is found, don't hide the row and move on to next row
'Debug.Print "Looking At: " & currentRow & "/" & startColumn & vbTab & currentRow - 1 & "/" & startColumn & vbTab & currentRow + 1 & "/" & startColumn
If ActiveSheet.Cells(currentRow, startColumn) < ActiveSheet.Cells(currentRow - 1, startColumn) And ActiveSheet.Cells(currentRow, startColumn) < ActiveSheet.Cells(currentRow + 1, startColumn) Then ' 3/4 changed from > to <
'shouldHideRow = False
ActiveSheet.Cells(currentRow, startColumn).EntireRow.Hidden = True ' 3/4 Just hide it!
'Exit For
End If
'Next
'If shouldHideRow Then ' 3/4 Not needed with above change
' 'drop into here if there was not a local maximum
' Debug.Print "Hide: " & currentRow & "/" & startColumn
' ActiveSheet.Cells(currentRow, startColumn).EntireRow.Hidden = True
'End If
Next
End Sub