I have a set of x names (in row 4) with corresponding dates (row 3) (the combination of name and date is unique).
I would like to copy the unique name and date, and then paste it x times (where x is the total number of names) in a different sheet.
I would like the code to loop through all names and dates and paste them within column A,B in a new sheet. Where column A has heading name and column B has heading date.
Initial data:
After Code:
What I have attempted so far - i can't seem to get the paste correct
Sub Test()
Dim o As Variant
Dim CountC_Range As Range
Dim cel_3 As Range
Dim MyRange As Range
'count the number of different engagement areas
Worksheets("Sheet8").Activate
Range("B4").Select
Set CountC_Range = Range("B4", Selection.End(xlToRight))
'Set the letter k as number of engagements as we'll use this later
o = WorksheetFunction.CountA(CountC_Range) - "1"
Worksheets("sheet9").Activate
Range("A1").Select
MyRange = Range("Selection.End(xlDown) + 1", "Selection.End(xlDown) + o + 1")
For Each cel_3 In Worksheets("Sheet8").Range("4:4")
If cel_3.Value <> "" Then
MyRange = cel_3.Value
End If
Next cel_3
End Sub
There are plenty of ways to do it, but having this input:
The code below will provide this:
Sub TestMe()
With Worksheets("Source")
Dim k As Long
k = .Range("A4").End(xlToRight).Column
End With
With Worksheets("Target")
Dim i As Long, ii As Long
Dim currentRow As Long
For i = 1 To k
For ii = 1 To k
currentRow = currentRow + 1
.Cells(currentRow, "A") = Worksheets("Source").Cells(3, i)
.Cells(currentRow, "B") = Worksheets("Source").Cells(4, i)
Next
Next
End With
End Sub
Dependencies:
Name the input worksheet "Source"
Name the output worksheet "Target"
A must read - How to avoid using Select in Excel VBA
Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub
I have an Excel spreadsheet with several thousand lines of data which is broken up into multiple sections based on the Manager. I have created coding that hides any lines with a zero value within a range for the individual sections, but they run slow and I'm not sure if there is a faster way to accomplish the same result. Here is what I have so far:
Option Explicit
Public shp As Single
Public r1 As Single
Public r23 As Single
Public sFind as String
1st part of the coding, which designates the rows to be looped through within the manager group. I have a button for each Manager and a Sub Button#_Click() to go with each section of data. Below is an example for Button#1, each look the same other than row numbers being different.
Sub Button1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
shp = 6
r1 = 14
r23 = 36
Call Button_Macro
Application.ScreenUpdating = True
Application.DisplayAlerts = True
The above code calls the following code to run:
Sub Button_Macro()
Dim r as Single
Dim x as Single
Dim i as Single
Dim MyArray as Variant
Dim ShpName as String
ShpName = "Rounded Rectangle " & Shp
ActiveSheet.Shapes.Range(ShpName).Select
sFind = Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text
If sFine = "-" Then
ActiveSheet.Shapes.Range(Array(ShpName)).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "+"
Rows(r1 & ":" & r23).Hidden = True
Else
ActiveSheet.Shapes.Range(Array(ShpName)).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "-"
Rows(r1 & ":" & r23).Hidden = False
MyArray = Range(Cells(r1,4), Cells(r23,6)).Value
r = 1
x = r1
For i = r1 to r23
If MyArray(r,1) + MyArray(r,2) + MyArray(r,3) = 0 Then
Rows(x).EntireRow.Hidden = True
End If
x = x + 1
r = r + 1
Next i
End If
Cells(r1 - 1, 2).Select
End Sub
Next to each section of data there is a button that has a + when all rows in the Manager's section are hidden, then when you click the button it runs the code and changes the button text to - and only shows rows with values greater than zero. When I click the button, it takes roughly 10 seconds for the code to run. I know that doesn't sound like much, but people expect that when they click the button the rows with values should appear immediately, not 10 seconds later so I'm trying to find out if there is a faster way of coding this. Thanks.
Check if there are formulas relying on visible cells only then turn Calculation to manual in the beginning and back to automatic in the end. Otherwise it will re-calculate on every row hide.
Note that instead of using these Public variables
Public shp As Single
Public r1 As Single
Public r23 As Single
Public sFind as String
you should give them as parameters of your procedure. Also row numbers are of type Long not Single and sFind should be a local variable of Button_Macro and not Public:
Option Explicit
Public Sub Button_Macro(ByVal shp As Long, ByVal r1 As Long, ByVal r23 As Long)
Dim sFind as String
'your code here …
End Sub
And call it like
Public Sub Button1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Button_Macro shp:=6, r1:=14, r23:=36
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
In this part I would recommend to stop using multiple counters as they all depend on each other the following
r = 1
x = r1
For i = r1 to r23
If MyArray(r,1) + MyArray(r,2) + MyArray(r,3) = 0 Then
Rows(x).EntireRow.Hidden = True
End If
x = x + 1
r = r + 1
Next i
can be written as
Dim i As Long 'i must be long too
For i = r1 to r23
If MyArray(i-(r1-1),1) + MyArray(i-(r1-1),2) + MyArray(i-(r1-1),3) = 0 Then
Rows(i).EntireRow.Hidden = True
End If
Next i
Please replace your loop with this one. Yours is convoluted and runs many, many times.
For R = R1 To R23
Myarray = Range(Cells(R, 4), Cells(R, 6)).Value
If MyArray(1, 1) + MyArray(1, 2) + MyArray(1, 3) = 0 Then
ActiveSheet.Rows(R).EntireRow.Hidden = True
End If
Next R
Note that row and column numbers should be contained in variables of Long data type. That's sufficient because they will never contain fractions which Longs can't handle.
I have worked out another answer for you which is more comprehensive. It's contained in a single procedure which is called by all the buttons. Depending upon the position of the button it works out which rows to hide, even if you add or delete rows in the future. You can also add or delete buttons.
Sub ShowHide_Click()
' 020
Dim Ws As Worksheet
Dim Button As Shape
Dim ButtonName As String, NextName As String
Dim ButtonID As Integer
Dim ShowRows As Boolean ' True if "+" was clicked
Dim Rstart As Long, Rend As Long ' rows to hide
Dim RowRange As Range
Dim Arr As Variant
Dim R As Long
Set Ws = ActiveSheet ' better name the sheet
' get the name of the button that was pressed
ButtonName = Application.Caller
Set Button = Ws.Shapes(ButtonName)
' read and reset the button
With Button.TextFrame.Characters
ShowRows = .Text = "+"
.Text = IIf(ShowRows, "-", "+")
End With
' assume the first row to hide will be 1 row below the button
Rstart = Button.TopLeftCell.Row + 1
' extract the ID from the name
Do
NextName = Right(ButtonName, ButtonID)
ButtonID = ButtonID + 1
If ButtonID >= Len(ButtonName) Then Exit Sub
If Not IsNumeric(Right(ButtonName, ButtonID)) Then Exit Do
Loop
ButtonID = Val(NextName)
' name the next button in serial sequence
NextName = Trim(Left(ButtonName, Len(ButtonName) - Len(NextName))) _
& Str(ButtonID + 1)
With Ws
' this test will return False if Shape(NextName) doesn't exist
If .Shapes(NextName).Name = NextName Then
' this presumes that the last row to be hidden will be the one
' just above the next button's TopLeftCell.
Rend = .Shapes(NextName).TopLeftCell.Row - 1
Else
' the specified button wasn't found
' change column is column B isn't dominant in this regard
Rend = .Cells(Ws.Rows.Count, "B").End(xlUp).Row
End If
' set the range attached to the button
Set RowRange = .Range(.Rows(Rstart), .Rows(Rend))
' show or hide rows
RowRange.Rows.EntireRow.Hidden = Not ShowRows
If ShowRows Then
For R = Rstart To Rend
Arr = Ws.Range(Cells(R, 4), Cells(R, 6)).Value
Ws.Rows(R).EntireRow.Hidden = (Arr(1, 1) + Arr(1, 2) + Arr(1, 3) = 0)
Next R
' ' consider this alternative (Delete Dim Arr if you choose this)
' For R = Rstart To Rend
' Ws.Rows(R).EntireRow.Hidden = (Application.Count(Ws.Range(Cells(R, 4), Cells(R, 6))) = 0)
' Next R
End If
.Cells(Rstart, "B").Select
End With
End Sub
I have added a lot of comments to the code to show how the code works and how to adjust it to work with your worksheet. However, there are a few condition which your worksheet must meet.
The buttons must all be of the same type, like "Rounded Rectangle".
They must be numbered consecutively. The numbers must not start from 1 (though I can't see why they shouldn't) but they must be numbered consecutively top to bottom. You can't add a button in the middle, like 1, 2, 3, 7, 4, 5, 6. The numbering must be 1, 2, 3, 4, 5, 6, 7.
I have a basic userform and need the one textbox to increment the number on the Add/next command, which I get right until you at the "PO" prefix.
I am doing a basic PO entry userform that adds info into the "Entries" sheet. The PO number has a "PO" prefix when clicking the add command I am trying to get the number to increment.
Dim currentrow As Long
Dim NextNum As Long
Dim prefix As String
Dim i As Long
Private Sub frmPurchaseOrder_Initialize()
currentrow = 2
End Sub
Private Sub cmdAdd_Click()
Dim num As Integer
'to check the last filled row
lastrow = ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 1).value = txtDocNo.Text
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 2).value = txtLineNumber.Text
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 3).value = txtDocType.Text
'next one
Me.txtDocType = "PO"
Me.txtLine = Me.txtLine + 1
End Sub
Private Sub UserForm_Initialize()
currentrow = 2
Me.txtInvoiceDate = Date
Me.txtDocType = "PO"
Me.txtLine = "1"
Me.txtDocNo = Application.WorksheetFunction.max(Range("DocNoList")) + 1
End Sub
The DocNo is in the first column on the entries sheet, range named "DocNoList"
I would appreciate your help.
Since you have the "PO" prefix in front of all the document numbers the Max function doesn't work. It would seem to be easiest to just access the last row of your data and extract the numeric value from that. Replace this line
Me.txtDocNo = Application.WorksheetFunction.max(Range("DocNoList")) + 1
with
With ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp)
Me.txtDocNo.Value = Me.txtDocType.Value + CInt(Right(.Value2, Len(.Value2) - 2)) + 1
End With
Alternatively:
Dim strDocNo As String
strDocNo = ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp).Value2
Me.txtDocNo.Value = Me.txtDocType.Value + CInt(Right(strDocNo, Len(strDocNo) - 2)) + 1
Looking for VBA code to delete all rows that do not contain at least 1 highlighted cell (interior color used: REDINDEX).
Sample data sheet with randomly highlighted cells
you can do it like this:
Public Sub DeleteAllRowsWithNoHighlitedCells()
Dim iRow As Long
Dim lastColumn As Long
Dim aktRow As Range
Dim owsh As Worksheet
Set owsh = ActiveSheet
iRow = 1
lastColumn = 7
Do Until owsh.Cells(iRow, 1) = ""
Set aktRow = owsh.Range(Cells(iRow, 1), Cells(iRow, lastColumn))
If Not AktRowHasHighlightedCells(aktRow) Then
owsh.Rows(aktRow.Row).Delete
iRow = iRow - 1
End If
iRow = iRow + 1
Loop
End Sub
Private Function AktRowHasHighlightedCells(ByVal aktRow As Range) As Boolean
Dim aktcell As Variant
For Each aktcell In aktRow.Cells
If aktcell.Interior.ColorIndex = 3 Then
AktRowHasHighlightedCells = True
Exit Function
End If
Next aktcell
AktRowHasHighlightedCells = False
End Function
To explain what i mean. First you have to create a Button and put the DeleteAllRowsWithNoHiglitedCells - Procedure behind the Click-Event. Then until Column1 for each row is not empty, every Cell in the selected Row from column1 to lastColumn (you have to define or you also can get the lastusedColumn via VBA) is checked for a Interior.Colorindex = 3 (hard coded red) If the Function AktRowHasHighlightedCells is false, the row will be deleted and the rowCounter will be decreased.