I need to find out how to write some basic code that will take each cell's value (which will be an ID number) from a selected range, then match it to a cell in a master workbook, copy said cell's entire row, then insert it into the original document in place of the ID number. Here's the kicker: certain ID numbers may match with several items, and all items that have that number must be inserted back into the document. Here's an example:
Master Document Workbook
A B C D A B C D
1 a ab ac 2
2 b bc bd 3
2 b be bf
3 c cd de
I would select the cells containing 2 and 3 in the Workbook, which after running the code would give me this:
Workbook
A B C D
2 b bc bd
2 b be bf
3 c cd de
Here's what I have going on so far but it's a total mess. The only thing it's managed to successfully do is store the selected range in the Workbook I want to paste to. It won't compile past that because I don't understand much of the syntax in VBA:
Sub NewTest()
Dim rng As Range
Dim FirstRow As Range
Dim CurrentCol As String
Dim FirstRowVal As Integer
Dim CurrentColVal As Variant
Dim rngOffset As Range
CurrentCol = "Blah"
Set FirstRow = Application.InputBox("Select the row containing your first raw material", Type:=8)
FirstRowVal = FirstRow.Row
Set rng = (Application.InputBox("Select the cells containing your IC numbers", "Obtain Materials", Type:=8))
Set rngOffset = rng.Offset(0, FirstRowVal)
CurrentColVal = rng.Column
Call CopyPaste
End Sub
Sub CopyPaste()
Dim Blah As Range
Set x = Workbooks.Open("Workbook Path")
Workbooks.Open("Workbook Path").Activate
Set y = Workbooks.Open("Master Path")
Workbooks.Open("Master Path").Activate
With x
For Each Cell In rng
x.Find(rng.Cell.Value).Select
If Selection.Offset(0, -1) = Selection Then
Selection.EntireRow.Copy
Selection = Selection.Offset(0, -1)
Else
Selection.EntireRow.Copy
Blah = Selection
End If
Workbooks.Open("Workbook Path").Activate
Sheets("Formula Sheet").Select
Blah.Insert (rng.Cell)
End
Sheets("sheetname").Cells.Select
Range("A1").PasteSpecial
'Sheets("sheetname").PasteSpecial
.Close
End With
With x
.Close
End With
End Sub
Would very much appreciate anyone who could help point me in the right direction. Thanks.
I'll bite, you can use the output array to populate any range on any worksheet.
Sub FindAndMatch()
Dim arrMatchFrom() As Variant, arrMatchTo() As Variant, arrOutput() As Variant
Dim i As Integer, j As Integer, counter As Integer
counter = 0
arrMatchFrom = Range("A2:D6")
arrMatchTo = Range("G2:G3")
For i = LBound(arrMatchTo, 1) To UBound(arrMatchTo, 1)
For j = LBound(arrMatchFrom, 1) To UBound(arrMatchFrom, 1)
If arrMatchTo(i, 1) = arrMatchFrom(j, 1) Then
counter = counter + 1
ReDim Preserve arrOutput(4, counter)
arrOutput(1, counter) = arrMatchTo(i, 1)
arrOutput(2, counter) = arrMatchFrom(j, 2)
arrOutput(3, counter) = arrMatchFrom(j, 3)
arrOutput(4, counter) = arrMatchFrom(j, 4)
End If
Next
Next
For i = 1 To counter
For j = 1 To 4
Debug.Print arrOutput(j, i)
Cells(9 + i, j) = arrOutput(j, i)
Next
Next
End Sub
I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.
I have a variable number of rows.
I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.
Example:
ColA ColB ColC ColD
Monday A,B,C Red Email
Output:
ColA ColB ColC ColD
Monday A Red Email
Monday B Red Email
Monday C Red Email
Have tried something like:
colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
Rows.Insert(i)
Next i
Try this, you can easily adjust it to your actual sheet name and column to split.
Sub splitByColB()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
Do While r.row > 1
ar = Split(r.value, ",")
If UBound(ar) >= 0 Then r.value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
You can also just do it in place by using a Do loop instead of a For loop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:
Dim workingRow As Long
workingRow = 2
With ActiveSheet
Do While Not IsEmpty(.Cells(workingRow, 2).Value)
Dim values() As String
values = Split(.Cells(workingRow, 2).Value, ",")
If UBound(values) > 0 Then
Dim colA As Variant, colC As Variant, colD As Variant
colA = .Cells(workingRow, 1).Value
colC = .Cells(workingRow, 3).Value
colD = .Cells(workingRow, 4).Value
For i = LBound(values) To UBound(values)
If i > 0 Then
.Rows(workingRow).Insert xlDown
End If
.Cells(workingRow, 1).Value = colA
.Cells(workingRow, 2).Value = values(i)
.Cells(workingRow, 3).Value = colC
.Cells(workingRow, 4).Value = colD
workingRow = workingRow + 1
Next
Else
workingRow = workingRow + 1
End If
Loop
End With
This will do what you want.
Option Explicit
Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim lastrow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet4").Copy After:=.Worksheets("Sheet4")
Set ws = ActiveSheet
End With
With ws
lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = lastrow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub
A formula solution is close to your requirement.
Cell G1 is the delimiter. In this case a comma.
Helper E1:=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H$1,"")))+1
You must fill the above formula one row more.
A8:=a1
Fill this formula to the right.
A9:=LOOKUP(ROW(1:1),$E:$E,A:A)&""
Fill this formula to the right and then down.
B9:=MID($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))+1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)+1))-FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))-1)&""
Fill down.
Bug:
Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.
Given #A.S.H.'s excellent and brief answer, the VBA function below might be a bit of an overkill, but it will hopefully be of some help to someone looking for a more "generic" solution. This method makes sure not to modify the cells to the left, to the right, or above the table of data, in case the table does not start in A1 or in case there is other data on the sheet besides the table. It also avoids copying and inserting entire rows, and it allows you to specify a separator other than a comma.
This function happens to have similarities to #ryguy72's procedure, but it does not rely on the clipboard.
Function SplitRows(ByRef dataRng As Range, ByVal splitCol As Long, ByVal splitSep As String, _
Optional ByVal idCol As Long = 0) As Boolean
SplitRows = True
Dim oldUpd As Variant: oldUpd = Application.ScreenUpdating
Dim oldCal As Variant: oldCal = Application.Calculation
On Error GoTo err_sub
'Modify application settings for the sake of speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Get the current number of data rows
Dim rowCount As Long: rowCount = dataRng.Rows.Count
'If an ID column is specified, use it to determine where the table ends by finding the first row
' with no data in that column
If idCol > 0 Then
With dataRng
rowCount = .Offset(, idCol - 1).Resize(, 1).End(xlDown).Row - .Row + 1
End With
End If
Dim splitArr() As String
Dim splitLb As Long, splitUb As Long, splitI As Long
Dim editedRowRng As Range
'Loop through the data rows to split them as needed
Dim r As Long: r = 0
Do While r < rowCount
r = r + 1
'Split the string in the specified column
splitArr = Split(dataRng.Cells(r, splitCol).Value & "", splitSep)
splitLb = LBound(splitArr)
splitUb = UBound(splitArr)
'If the string was not split into more than 1 item, skip this row
If splitUb <= splitLb Then GoTo splitRows_Continue
'Replace the unsplit string with the first item from the split
Set editedRowRng = dataRng.Resize(1).Offset(r - 1)
editedRowRng.Cells(1, splitCol).Value = splitArr(splitLb)
'Create the new rows
For splitI = splitLb + 1 To splitUb
editedRowRng.Offset(1).Insert 'Add a new blank row
Set editedRowRng = editedRowRng.Offset(1) 'Move down to the next row
editedRowRng.Offset(-1).Copy Destination:=editedRowRng 'Copy the preceding row to the new row
editedRowRng.Cells(1, splitCol).Value = splitArr(splitI) 'Place the next item from the split string
'Account for the new row in the counters
r = r + 1
rowCount = rowCount + 1
Next
splitRows_Continue:
Loop
exit_sub:
On Error Resume Next
'Resize the original data range to reflect the new, full data range
If rowCount <> dataRng.Rows.Count Then Set dataRng = dataRng.Resize(rowCount)
'Restore the application settings
If Application.ScreenUpdating <> oldUpd Then Application.ScreenUpdating = oldUpd
If Application.Calculation <> oldCal Then Application.Calculation = oldCal
Exit Function
err_sub:
SplitRows = False
Resume exit_sub
End Function
Function input and output
To use the above function, you would specify
the range containing the rows of data (excluding the header)
the (relative) number of the column within the range with the string to split
the separator in the string to split
the optional (relative) number of the "ID" column within the range (if a number >=1 is provided, the first row with no data in this column will be taken as the last row of data)
The range object passed in the first argument will be modified by the function to reflect the range of all the new data rows (including all inserted rows). The function returns True if no errors were encountered, and False otherwise.
Examples
For the range illustrated in the original question, the call would look like this:
SplitRows Range("A2:C2"), 2, ","
If the same table started in F5 instead of A1, and if the data in column G (i.e. the data that would fall in column B if the table started in A1) was separated by Alt-Enters instead of commas, the call would look like this:
SplitRows Range("F6:H6"), 2, vbLf
If the table contained the row header plus 10 rows of data (instead of 1), and if it started in F5 again, the call would look like this:
SplitRows Range("F6:H15"), 2, vbLf
If there was no certainty about the number of rows, but we knew that all the valid rows are contiguous and always have a value in column H (i.e. the 3rd column in the range), the call could look something like this:
SplitRows Range("F6:H1048576"), 2, vbLf, 3
In Excel 95 or lower, you would have to change "1048576" to "16384", and in Excel 97-2003, to "65536".
Goal: I want to build 4 different strings with method Contagenation. I have a dynamic count of columns (column 4 to maxCol) in each of 4 rows (row 32 to row 35) in sheet ("Calc"). The 4 different strings should be stored in another sheet ("CreateColumns")in cells (A1, A2, A3, A4)
Problem: I have coded the following code to achieve that goal but in sheet ("CreateColumns") each of the 4 rows are filled with the same value = last value of row 35 in sheet("Calc") and not with the 4 different values as intended.
Question: What is the error in my code?
Sub CreateColumns()
Dim maxCol As Integer
Dim x As String
Dim rng As Range
Dim cel As Range
Dim i As Long
Dim row As Long
Dim y As Long
Sheets("Calc").Select
maxCol = Cells(32, columns.Count).End(xlToLeft).column
For row = 32 To 35
Sheets("Calc").Select
Cells(row, 4).Activate
For i = 4 To maxCol
With Worksheets("Calc")
Set rng = Range(.Cells(row, 4), .Cells(row, maxCol))
End With
x = ""
For Each cel In rng
x = x & cel.Value
For y = 1 To 4
Sheets("ColCreate").Cells(y, 1).Value = x
Next
Next
Next
Next
End Sub
The issue in your code is that the part where you paste to sheet "ColCreate" is a bit out of place - it should occur once for each occurence of your outermost loop, alongside the "y" increment
I have slightly amended your code below, should provide the expected result
Sub CreateColumns()
Dim maxCol As Integer
Dim x As String
Dim rng As Range
Dim cel As Range
Dim i As Long
Dim row As Long
Dim y As Long
Sheets("Calc").Select
maxCol = Cells(32, Columns.count).End(xlToLeft).Column
y = 1
For row = 32 To 35
Sheets("Calc").Select
Cells(row, 4).Activate
For i = 4 To maxCol
With Worksheets("Calc")
Set rng = Range(.Cells(row, 4), .Cells(row, maxCol))
End With
x = ""
For Each cel In rng
x = x & cel.Value
Next
Next
Sheets("ColCreate").Cells(y, 1).Value = x
y = y + 1
Next
End Sub
I would like to copy the following four formulas and paste it in the adjacent four columns with the column reference changing by four everytime. What i mean is copy F4:I4 and paste to J4:M4,N4:Q4...with the "F" cahnging to a "J", then "N", then "Q" and so on until the end of the columns in the sheet.
=IF(AND(F2>=$C$4,F2<=$D$4),TRUE, FALSE)
=IF(AND((F2+6)>=$C$4,(F2+6)<=$D$4),TRUE,FALSE)
=IF(AND((F2+12)>=$C$4,(F2+12)<=$D$4),TRUE,FALSE)
=IF(AND((F2+18)>=$C$4,(F2+18)<=$D$4),TRUE,FALSE)
Am I able to some way loop this going across each column, and after the fourth add four to the numerical value of the cell reference? so instead of F2 and J2 I have Col_ID, Col_ID+4...Not sure how to write this in VBA. Any help would be greatly appreciated.
I used this to merge every four cells above to make the "labels", i'm thinking I can re-use this but not sure how.
Dim Rng As Range
Dim ws As Worksheet
Dim R1 As Long, C1 As Long
Dim R2 As Long, C2 As Long
Dim lastCol As Long
Set ws = ThisWorkbook.Sheets("Dashboard")
R1 = 3: C1 = 6
R2 = 3: C2 = C1 + 3
lastCol = 1
While lastCol < 256
With ws
Set Rng = .Range(.Cells(R1, C1), .Cells(R2, C2))
Application.DisplayAlerts = False
Rng.Merge
Application.DisplayAlerts = True
C1 = C2 + 1
C2 = C1 + 3
lastCol = lastCol + 1
End With
Wend
This will copy a source range to as many groups of four columns as you specify with NumberOfCopies. You didn't say what range you are copying from, so I assumed G3:J3:
Sub CopyCols()
Dim rngSource As Excel.Range
Dim rngTarget As Excel.Range
Dim NumberOfCopies As Long
NumberOfCopies = 12
With ActiveSheet
Set rngSource = .Range("G3:J3")
Set rngTarget = .Range("K3").Resize(rngSource.Rows.Count, NumberOfCopies * 4)
rngSource.Copy Destination:=rngTarget
End With
End Sub
The code below is supposed to get the next record when a button is clicked in an input sheet.
My button is named CurrRecNew on sheet3 when I click it performs the code below but it doesn't appear to increment. Any suggestions on what I am doing wrong?
The datasheet sheet 1 has cells starting in Row A3 and going down eg
A3 1 B3 a
A4 Blank B4 b
A5 Blank B5 c
A6 2 B6 d
A7 Blank B7 f
A8 Blank B8 g
A9 Blank B9 h
A8 3 B10 ...
Sub ViewLogDown()
Dim historyWks As Worksheet
Dim InputWks As Worksheet
Dim lRec As Long
Dim lRecRow As Long
Dim lLastRec As Long
Dim LastRow As Long
Dim Rlen As Long
Dim lCurrentRow As Long
lCurrentRow = lCurrentRow + 1
Application.EnableEvents = False
Set InputWks = Worksheets("Sheet3")
Set historyWks = Worksheets("Sheet1")
With historyWks
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
lLastRec = LastRow - 1
End With
With InputWks
lCurrentRow = lCurrentRow + 1
lRec = .Range("CurrRecNew").Value
Do While Len(Cells(lCurrentRow, 1).Value) = 0
lCurrentRow = lCurrentRow + 1
Loop
lCurrentRow = lCurrentRow - 1
.OLEObjects("tbRiskID").Object.Value = historyWks.Cells(lCurrentRow, 1)
.OLEObjects("tbRiskContext").Object.Value = historyWks.Cells(lCurrentRow, 2)
.OLEObjects("TextBox34").Object.Value = historyWks.Cells(lCurrentRow, 3)
.OLEObjects("tbRiskEx").Object.Value = historyWks.Cells(lCurrentRow, 4)
.OLEObjects("tbRiskCat").Object.Value = historyWks.Cells(lCurrentRow, 5)
End With
Application.EnableEvents = True
End Sub
Your code is very confusing, you are finding the lCurrentRow on the InputWks sheet but then setting the textbox objects to the lcurrentrow on the Historywks sheet??? You need to explain clearly what each worksheet does, which sheet you want to find the next row on etc.
I presume that the you are using the named range CurrRecNew to store the current row. And you are wanting get the current row on the historywrks sheet. Therefore as far as finding the next row which is your actual question your code should look something like this:
Dim rFound As Range
'// History sheet
With historyWks
'// Get current row, you need to correctly define the sheet name which contains the CurrRecNew Range.
lCurrentRow = InputWks.Range("CurrRecNew").Value
Set rFound = .Columns(1).Find(What:="*", After:=.Cells(lCurrentRow, 1))
If Not rFound Is Nothing Then
If rFound.Row > lCurrentRow Then
lCurrentRow = rFound.Row
txtName.Text = Cells(lCurrentRow, 1).Value
txtPhone.Text = Cells(lCurrentRow, 2).Value
End If
End If
'// Once again correct the sheet name here I guessed CurrRecNew was on the InputWks sheet
InputWks.Range("CurrRecNew").Value = lCurrentRow
End with