I am currently working on the following excel sheet:
this is the excel sheet
I am quite new to Excel and I just found out about the VBA function. Do you guys think that it is possible to write a code that does essentially the following:
If [Total Debt Stock] -> select the next 6 cells below and add to these cells "TDS" at the beginning.
And follwing this: If [short-term debt] -> select the next 2 (for instance) cells below and add "STD".
The aim is to copy the following pdf and also keep the "embeddedness" structure of the pdf (i.e. Albania-Total Debt-Short Term Debt- Official creditior) so that STATA can use that easily this is the pdf
Has anyone ever done something like this?
Thanks in advance!
All the best,
Greg
If I understand you correctly, then I think you can use the following:
Public Sub Main()
Dim lRow As Long
Dim lLoop As Long
For lRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If InStr(1, LCase(Cells(lRow, 1)), "total debt stock") > 0 Then
For lLoop = 1 To 6
Cells(lRow + lLoop, 1) = "TDS-" & Cells(lRow + lLoop, 1)
Next lLoop
lRow = lRow + 6
End If
If InStr(1, LCase(Cells(lRow, 1)), "short-term debt") > 0 Then
For lLoop = 1 To 2
Cells(lRow + lLoop, 1) = "STD-" & Cells(lRow + lLoop, 1)
Next lLoop
lRow = lRow + 2
End If
Next lRow
End Sub
For testing if a cell "contains" either Total Debt Stock or Short-term debt, I change everything to lowercase, so you might want to change that. I also added a hyphen after "TDS" and "STD".
Related
In my quest to improve the quality of life at work, I've searched for an answer and wound up borrowing this code (posted my current attempt at bottom of the post) to extract differences between two worksheets. While it returns the basic information, it is less QoL change than my current method, which, while it works most of the time, still fails. The current method is as follows:
=IF(COUNTIFS(New!$H:$H, Old!$H2, New!$C:$C, Old!$C2,New!$B:$B, Old!$B2)<1, Old!$H2, "")
This code spans across several columns to populate the appropriate information (appointment time, date, patient name, patient ID, notes, etc). This goes on a sheet called "Removed", and I have one for "Added" where New and Old are reversed.
I attempted to modify the borrowed code to paste entire rows instead of just one column, but I seem to be failing at every turn, mainly because I am new to VBA and do not have a full grasp of it yet. Changing the first For loop to:
For i = LBound(valsM, 1) To UBound(valsM, 1)
If IsError(Application.Match(valsM(i, 1), valsQ, 0)) Then
mm = mm + 1
Worksheets("Old").Cells(i).EntireRow.Copy Destination:= Worksheets("New").Cells(mm, 1)
End If
Next i
is obviously the incorrect way, and I suspect it's due to the whole thing being based on arrays. What must I change in the script to accommodate 16 columns of information that must be moved over to appropriate pages? Bonus would be putting them all on one page and appending a 17th column Q that indicates removed or added. Appreciate the help.
Sub YouSuckAtVBA()
Dim i As Long, mm As Long
Dim valsM As Variant, valsQ As Variant, valsMM As Variant
With Worksheets("New")
valsM = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
With Worksheets("Old")
valsQ = .Range(.Cells(1, "H"), .Cells(.Rows.Count, "H").End(xlUp)).Value2
End With
ReDim valsMM(1 To (UBound(valsM, 1) + UBound(valsQ, 1)), 1 To 2)
mm = 1
valsMM(mm, 1) = "value"
valsMM(mm, 2) = "missing from"
For i = LBound(valsM, 1) To UBound(valsM, 1)
If IsError(Application.Match(valsM(i, 1), valsQ, 0)) Then
mm = mm + 1
Worksheets("Old").Cells(i).EntireRow.Copy Destination:=Worksheets("New").Cells(mm, 1)
End If
Next i
For i = LBound(valsQ, 1) To UBound(valsQ, 1)
If IsError(Application.Match(valsQ(i, 1), valsM, 0)) Then
mm = mm + 1
Worksheets("New").Cells(i).EntireRow.Copy Destination:=Worksheets("Old").Cells(mm, 1)
End If
Next i
valsMM = helperResizeArray(valsMM, mm)
With Worksheets("Test")
With .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
.Resize(UBound(valsMM, 1), UBound(valsMM, 2)) = valsMM
End With
End With
End Sub
Function helperResizeArray(vals As Variant, x As Long)
Dim arr As Variant, i As Long
ReDim arr(1 To x, 1 To 2)
For i = LBound(arr, 1) To UBound(arr, 1)
arr(i, 1) = vals(i, 1)
arr(i, 2) = vals(i, 2)
Next i
helperResizeArray = arr
End Function
If you have Office 365 you can use the new Filter-Function
The screenshot shows the formulas using a very basic example.
"Table old" and "Table new" are created via "Insert > Table" therefore it is possible to reference the column names within the formula instead of B or D
I have existing script that does a major chunk of what I need. The script (from here: https://www.extendoffice.com/documents/excel/4054-excel-duplicate-rows-based-on-cell-value.html) basically inserts and then copies rows of data X number of times, where X is one of the fields in the table. It works well and the referenced page shows examples of the start and end points.
But when I run the script in Excel I go from ~2,000 lines in my table to ~40,000 lines. I need to modify all the duplicated rows (incremental dates) and so I am now attemting to also include new data into the table while the script runs that will allow me to change data in the duplicated rows... for example I can use the duplicate number 1, 2, 3, 4 and some simple formulas to change dates relative to a start point.
I expect that I will need some additional code inserted into the routine that will add data into a nominated column and do the auto incrementing from 1.
Having zero actual VBA skillz, ive no idea how to tackle the second part of my problem with the code I already have. Any help would be totally awesome !!
Sub CopyData()
'Updateby Extendoffice 20160922
Dim xRow As Long
Dim VInSertNum As Variant
xRow = 1
Application.ScreenUpdating = False
Do While (Cells(xRow, "A") <> "")
VInSertNum = Cells(xRow, "D")
If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
Range(Cells(xRow, "A"), Cells(xRow, "D")).Copy
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "D")).Select
Selection.Insert Shift:=xlDown
xRow = xRow + VInSertNum - 1
End If
xRow = xRow + 1
Loop
Application.ScreenUpdating = False
End Sub
Try this code below, I used the same sample data on the link you provided. However on this code I created 2 worksheets, one for the raw data to be processed and one for the duplicate output including the increment of dates and duplicate number.
Sub duplicateData()
Dim rSH As Worksheet
Set rSH = ThisWorkbook.Sheets("RAW") 'Your raw data
Dim oSH As Worksheet
Set oSH = ThisWorkbook.Sheets("OUTPUT") 'Output data on another sheet
x = 2
For a = 2 To rSH.Range("A" & Rows.Count).End(xlUp).Row
For b = 1 To rSH.Cells(a, 4).Value '4 is the column of duplicate times
If b = 1 Then
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 5) = 1 'First instance, 5 is the column number of duplicate counter
Else
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 3).Value = CDate(oSH.Cells(x - 1, 3).Value) + 1 '3 is the column number of date to increment
oSH.Cells(x, 5).Value = CInt(oSH.Cells(x - 1, 5).Value) + 1 '5 is the column number of duplicate counter
End If
x = x + 1 'Increment Output row number
Next b
Next a
End Sub
I am new to excel and VBA so apologies for silly question or mistake.
i have some 2000 excel data in sheet2 and the data req in sheet 1
I need to know how many ticket which starts with INC and priority P2 P3 are there and same way how many tickets which starts with SR are there. also out of them how many are in closed state and how many are active.
Sub US_Data()
Dim z As Long
Dim C As Range
z = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
For Each C In Sheet2.Range(Sheet2.Cells(2, 1), Sheet2.Cells(z, 1))
If Left(C.Value, 3) = "INC" Then
Sheet1.Cells(8, 6) = Sheet1.Cells(8, 6) + 1
End If
Next C
End Sub
Thank you
Why use VBA at all? This can be done with simple formulas. If you don't want to use pivot tables, manually create the headings (Blue in the screenshot), then put this formula into cell H3, copy across and down.
=COUNTIFS($A:$A,$G3&"*",$B:$B,H$1,$C:$C,H$2)
Change the layout if you want. The point is that you don't need VBA for that. Formulas will be a lot faster than re-inventing a CountIfs with VBA.
Sub US_Data()
Dim z As Long
Dim HighCount as Long
Dim ModerCount as Long
Dim LowCount as Long
Dim OpenCount as Long
Dim ClosedCount as Long
Dim C As Range
z = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
For Each C In Sheet2.Range(Sheet2.Cells(2, 1), Sheet2.Cells(z, 1))
If Left(C.Value, 3) = "INC" Then
If C.Offset(0,1).Value = "2 - High" Then HighCount = HighCount + 1
If C.Offset(0,1).Value = "3 - Moderate" Then ModerCount = ModerCount + 1
If C.Offset(0,1).Value = "4 - Low" Then LowCount = LowCount + 1
If C.Offset(0,2).Value = "Closed" Then ClosedCount = ClosedCount + 1
If C.Offset(0,2).Value = "Open" Then OpenCount = OpenCount + 1
End If
Next C
MsgBox "I have counted " & HighCount & " times High, " & ModerCount & " times Moderate, " & LowCount & " times Low, and respectively " & OpenCount & " and " & ClosedCount & " open and closed instances.", vbOkOnly, "FYI"
Sheet1.Cells(8, 6) = HighCount
End Sub
This would be one way of doing it, you can fill the cells necessary with those variables.
I am having trouble determining a way to enter a 1 or 0 into an adjacent cell to indicate whether or not a value is unique when working with a large dataset. I have read of multiple methods for accomplishing this, however none of them seem efficient for my purposes: I am using an instance of Excel 2010 (so I do not have the Distinct Count feature in PivotTables, and when I try to use PowerPivot it crashes my file due to processing limitations.
In this StackOverflow question: Simple Pivot Table to Count Unique Values there are suggestions to use SUMPRODUCT or COUNTIF, but when working with 50,000+ rows as I am, this causes terrible performance and a file size of ~35 MB instead of ~3 MB. I wanted to know if there is a better solution for a large, dynamic dataset whether it is a formula or VBA.
An example of what I would like to accomplish is (with the Unique column being the adjacent cell):
Name Week Unique
John 1 1
Sally 1 1
John 1 0
Sally 2 1
I attempted to script the same functionality of COUNTIF but with no success:
For Each Cell In ThisWorkbook.Worksheets("Overtime & Type Data").Range("Z2:Z" & DataLastRow)
If Worksheets("Overtime & Type Data").Cells(Cell.Row, 26) <> Worksheets("Overtime & Type Data").Cells(Cell.Row - 1, 26) Then
FirstCell = Cell.Row
End If
If (Worksheets("Overtime & Type Data").Range(Cells(FirstCell, 26), Cells(Cell.Row, 26)) = Worksheets("Overtime & Type Data").Range(Cells(Cell.Row, 26))) = True Then
Cell.Value = 1
Else
Cell.Value = 0
End If
Next Cell
This code ran on over 130,000 rows successfully in less than 3 seconds. Adjust the column letters to fit your dataset.
Sub tgr()
Const colName As String = "A"
Const colWeek As String = "B"
Const colOutput As String = "C"
Dim ws As Worksheet
Dim rngData As Range
Dim DataCell As Range
Dim rngFound As Range
Dim collUniques As Collection
Dim arrResults() As Long
Dim ResultIndex As Long
Dim UnqCount As Long
Set ws = ThisWorkbook.Sheets("Overtime & Type Data")
Set rngData = ws.Range(colName & 2, ws.Cells(Rows.Count, colName).End(xlUp))
Set collUniques = New Collection
ReDim arrResults(1 To rngData.Cells.Count, 1 To 1)
On Error Resume Next
For Each DataCell In rngData.Cells
ResultIndex = ResultIndex + 1
collUniques.Add ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value, ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value
If collUniques.Count > UnqCount Then
UnqCount = collUniques.Count
arrResults(ResultIndex, 1) = 1
Else
arrResults(ResultIndex, 1) = 0
End If
Next DataCell
On Error GoTo 0
ws.Cells(rngData.Row, colOutput).Resize(rngData.Cells.Count).Value = arrResults
End Sub
One approach is to sort by Name and Week. Then you can determine Unique for any row by comparing with the previous row.
If you need to preserve the order, you could first write a column of Index numbers (1, 2, 3, ...) to keep track of order. After calculating Unique, sort by Index to restore the original order.
The whole process could be done manually with relatively few steps, or automated with VBA.
I'm not sure how well this will work with 50000 values, but it goes through ~1500 in about a second.
Sub unique()
Dim myColl As New Collection
Dim isDup As Boolean
Dim myValue As String
Dim r As Long
On Error GoTo DuplicateValue
For r = 1 To Sheet1.UsedRange.Rows.Count
isDup = False
'Combine the value of the 2 cells together
' and add that string to our collection
'If it is already in the collection it errors
myValue = Sheet1.Cells(r, 1).Value & Sheet1.Cells(r, 2).Value
myColl.Add r, myValue
If isDup Then
Sheet1.Cells(r, 3).Value = "0"
Else
Sheet1.Cells(r, 3).Value = "1"
End If
Next
On Error GoTo 0
Exit Sub
DuplicateValue:
'The value is already in the collection so put a 0
isDup = True
Resume Next
End Sub
Just about any bulk operation will beat a loop involving worksheet cells. You might be able to trim the time down a bit by performing all of the calculations in memory and only returning the values back to the worksheet en masse when it is complete.
Sub is_a_dupe()
Dim v As Long, vTMP As Variant, vUNQs As Variant, dUNQs As Object
Debug.Print Timer
On Error GoTo bm_Uh_Oh
Set dUNQs = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
vTMP = .Range(.Cells(2, 1), .Cells(Rows.Count, 2).End(xlUp)).Value2
ReDim vUNQs(1 To UBound(vTMP, 1), 1 To 1)
For v = LBound(vTMP, 1) To UBound(vTMP, 1)
If dUNQs.Exists(Join(Array(vTMP(v, 1), vTMP(v, 2)))) Then
vUNQs(v, 1) = 0
Else
dUNQs.Add Key:=Join(Array(vTMP(v, 1), vTMP(v, 2))), _
Item:=vTMP(v, 2)
vUNQs(v, 1) = 1
End If
Next v
.Cells(2, 3).Resize(UBound(vUNQs, 1), 1) = vUNQs
End With
Debug.Print Timer
bm_Uh_Oh:
dUNQs.RemoveAll
Set dUNQs = Nothing
End Sub
Previous experience tells me that the variety of data (as well as hardware, etc) will impact timing the process but in my random sample data I received these elapsed times.
50K records ..... 0.53 seconds
130K records .... 1.32 seconds
500K records .... 4.92 seconds
I want to do something like:
E18-(1,1) &":" &E18+(1,1)
My intent is to keep the selection of range E18 (value = B) and extend the selection to D16:F20.
If I have a cell's range of E18 and I want to extend the range to D16:F20, how can I do this?
You mean like this?
SYNTAX
ExpandRange [Range], [Number of Col on left], [Number of Rows on Top], [Number of Col on right], [Number of Rows down]
Sub Sample()
Debug.Print ExpandRange(Range("B5"), 1, 1, 1, 1) '<~~ $A$4:$C$6
Debug.Print ExpandRange(Range("A1"), 1, 1, 1, 1) '<~~ Error
Debug.Print ExpandRange(Range("XFD4"), 1, 1, 1, 1) '<~~ Error
Debug.Print ExpandRange(Range("XFD1048576"), 1, 1, 1, 1) '<~~ Error
Debug.Print ExpandRange(Range("E5"), 1, 1, 1, 1) '<~~ $D$4:$F$6
End Sub
Function ExpandRange(rng As Range, lft As Long, tp As Long, _
rt As Long, dwn As Long) As String
If rng.Column - lft < 1 Or _
rng.Row - tp < 1 Or _
rng.Column + rt > ActiveSheet.Columns.Count Or _
rng.Row + dwn > ActiveSheet.Rows.Count Then
ExpandRange = "Error"
Exit Function
End If
ExpandRange = Range(rng.Offset(-1 * tp, -1 * lft).Address & ":" & _
rng.Offset(dwn, rt).Address).Address
End Function
Here is the simple code that I use to resize an existing selection.
Selection.Resize(Selection.Rows.Count + 5, Selection.Columns.Count + 50).Select
This will add 5 to the row count and 50 to the column count. Adapt to suit your needs.
You can use Application.WorksheetFunction.Offset() which is richer than VBA's Offset and does everything required by the question.
I think it does what Siddharth Rout ExpandRange does, without the need of a UDF.
Range(Cells(WorksheetFunction.Max(1, Selection.Row - 1), _
WorksheetFunction.Max(1, Selection.Column - 1)), _
Cells(WorksheetFunction.Min(Selection.Worksheet.Rows.Count, _
Selection.Row + 1), _
WorksheetFunction.Min(Selection.Worksheet.Columns.Count, _
Selection.Column + 1))).Select
upd: thanks Siddharth Rout for formating my msg
How to select and extend a range from anywhere on a sheet, to anywhere on a sheet.
This is my first post. I know I'm a little bit late to the party, and it's obvious to me that most of the people here are far far more experienced and skilled than I am. So I doubt my solutions include much of their "big picture" nuanced considerations, but I've verified they work for me and I hope they work for all of you too.
Okay, so back to the question.
Here is how I do it.
Example One
To do this for the exact scenario posed by your question, if you’re starting at E18 and you want to extend the range to D16:F20, use the code below. As long as you have room for the full range, your active cell can actually be anywhere, and that range will follow it.
Range(ActiveCell.Offset(-2, -1), ActiveCell.Offset(2, 1)).Select
Example Two
If you’ve already selected a range, and then you want to expand it further (let’s say and additional 2 rows down and 1 column to the right), then do this:
Range(Selection, Selection.Offset(2, 1)).Select
Example Three
If you want to select a range of all the contiguous cells containing data, starting from the active cell and continuing down until it reaches a blank cell, and then also add the cells from 1 column to the left, then do this:
Range(ActiveCell, Selection.End(xlDown).Offset(0, -1)).Select
Instead of returning an absolute address, I modifying the syntax above to return a range. Credit goes to Siddharth Rout = )
Function ExpandRG(rng As Variant, lft As Long, tp As Long, rt As Long, dwn As Long) _
As Range
Set ws = rng.Parent
If rng.Column - lft < 1 Or _
rng.Row - tp < 1 Or _
rng.Column + rt > ActiveSheet.Columns.Count Or _
rng.Row + dwn > ActiveSheet.Rows.Count Then
MsgBox "Out of range"
Exit Function
End If
Set rng = ws.Range(rng.Offset(-1 * tp, -1 * lft).Address & ":" & _
rng.Offset(dwn, rt).Address)
End Function
Sub aa()
Dim ori_add, O_add, New_add As Range
Set ori_add = Range("B2")
Set O_add = ori_add
Call ExpandRG(ori_add, 1, 1, 1, 1)
Set New_add = ori_add
MsgBox "Original address " & O_add.Address & ", new address is" & New_add.Address
End Sub