Insert row to separates group of data with header - excel

Would anyone will be able to help me with this script please?
As it stand, this current macro separate the data once the value/text have changes and insert new row but I just cannot work it out how to include the headers once the row have been inserted.
Sub Insert Row()
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Set ws = Worksheets("Sheet1") 'the sheet with the data
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data in Column A
For i = lr - 1 To 2 Step -1
If ws.Range("A" & i).Value <> ws.Range("A" & i + 1).Value Then ws.Range("A" & i + 1).EntireRow.Insert
Next i
End Sub
Thank you in advanced.

Duplicate Headers
A Quick Fix
Sub InsertHeaders()
Const FIRST_ROW As Long = 1
Const EMPTY_ROWS As Long = 1
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim r As Long
For r = LastRow To FIRST_ROW + 2 Step -1
With ws.Cells(r, "A")
If .Value <> .Offset(-1).Value Then
.EntireRow.Resize(EMPTY_ROWS + 1).Insert
ws.Rows(1).Copy ws.Rows(.Row - 1)
End If
End With
Next r
End Sub

Please ignore my comment, as I just realize that it will be a different result if in column A there is a cell with the same value.
Example Data :
Expected result after running the sub :
Sub test()
Dim rgHdr As Range: Dim rgData As Range: Dim cell As Range
Dim i As Integer: Dim arr: Dim ins As Integer:dim sh as worksheet
Set sh = Sheets("Sheet1") 'change if needed
ins = 3 'change if needed
With sh
.Range("A1").EntireRow.Resize(ins).Insert Shift:=xlDown
Set rgHdr = .Range("A1").EntireRow.Resize(1 + ins)
Set rgData = .Range("K" & 2 + ins, .Range("K" & Rows.Count).End(xlUp))
End With
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgData: arr.Item(cell.Value) = 1: Next
For i = 1 To arr.Count - 1
rgHdr.Copy
sh.Cells(rgData.Find(arr.Keys()(i), _
after:=rgData.End(xlDown)).Row, 1).Insert Shift:=xlDown
Next
sh.Range("A1").EntireRow.Resize(ins).Delete
End Sub
sh = the sheets where the data is.
ins = skip how many blank rows.
The code use "insert copied cells" method, so it make three blank rows (the value of ins) before the header, then set the first three rows as rgHdr, set the rgData from K2 down to the last row with value.
arr = unique value in column K.
then it loop to each element in arr, get the first row occurence of the found cell which value is the looped element in arr, insert the copied rgHdr to that row.
Then finally it delete those three (ins value is 3) additional blank rows.

Related

Loop can't process array

I apologize for the vague title as I'm not really sure where the error is. I think I'm having some compability issues with copying the elements of an array and then manipulating that data.
This is the code I have so far:
Sub listNotCompletedTasks()
Dim cell As Range
Dim sourceRange As Range
Dim targetRange As Range
Dim notCompleted() As Variant
Dim i As Integer
Dim lastr As Integer
'define sourceRange
lastr = Range("A" & Rows.count).End(xlUp).Row
Set sourceRange = Range("A2:A" & lastr)
'notCompleted is an array with all the offset cells of the cells in sourceRange
'that don't contain a "Completed" string
i = 0
For Each cell In sourceRange.Cells
If cell.Offset(0, 2).Value <> "Completed" Then 'if the cell in column C does not contain "completed"...
ReDim Preserve notCompleted(0 To i)
notCompleted(i) = cell.Value 'add cell in column A to array
i = i + 1
End If
Next cell
'define targetRange
lastRow = Cells(Rows.count, "Z").End(xlUp).Row
Set targetRange = Range("Z1:Z" & lastRow)
'copy all elements from the array to the targetRange
For i = 0 To UBound(notCompleted)
targetRange.Offset(i, 0).Value = notCompleted(i)
Next i
End Sub
Expected output:
This works well. The problem begins with the second step:
Sub listNoDuplicatesAndNoOfInstances()
Dim sourceRangeZ As Range
Dim targetRangeB As Range
Set sourceRangeZ = Sheets("SourceData").Range("Z2")
Set targetRangeB = Sheets("TargetSheet").Range("B17")
'add all of the unique instances of a string in Z from the notCompleted() array
Do Until IsEmpty(sourceRangeZ)
If Application.WorksheetFunction.CountIf(Sheets("TargetSheet").Range("B:B"), sourceRangeZ.Value) = 0 Then
targetRangeB.Value = sourceRangeZ.Value
Set targetRangeB = targetRangeB.Offset(1, 0)
Else
End If
Set sourceRangeZ = sourceRangeZ.Offset(1, 0)
Loop
'count every instance of those strings and add the value to the respective cell to the right
Set targetRangeB = Sheets("TargetSheet").Range("C17")
Do Until IsEmpty(targetRangeB.Offset(0, -1))
targetRangeB.Formula = "=COUNTIF(SourceData!Z:Z,Z" & targetRangeB.Row & ")"
Set targetRangeB = targetRangeB.Offset(2, 0)
Loop
End Sub
The first loop (the one that adds every unique instance of the strings to column B) works. The second loop (the one that returns the number of instances of each string) does not work, only returning zeroes. The thing is, if I manually do the steps of the first subroutine (use a Pivot Table to filter out the rows I need, then copy the relevant row and paste it to column Z), and then call the second subroutine, then it actually works!
So I'm assuming the first subroutine is the culprit. A "cheap" workaround that worked for me was to copy the range in Z to another column (using sourceRange.Copy/targetRange.PasteSpecial xlPasteAll) and then call the second subroutine. What am I doing wrong, and is there a better way to solve this?
A 2D array you can copy to sheet without looping.
Sub listNotCompletedTasks()
Dim wsSource As Worksheet, arNotCompl()
Dim lastrow As Long, i As Long, n As Long
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim arNotCompl(1 To lastrow, 1 To 1)
For i = 2 To lastrow
If .Cells(i, "C") <> "Completed" Then
n = n + 1
arNotCompl(n, 1) = .Cells(i, "A")
End If
Next
If n = 0 Then Exit Sub
'copy array to targetRange
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
.Cells(lastrow + 1, "Z").Resize(n) = arNotCompl
End With
End Sub
Add the formula in column C when you add the unique value to column B.
Sub listNoDuplicatesAndNoOfInstances()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lastrow As Long, i As Long, n As Long
Dim arNotCompl(), v
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
arNotCompl = .Range("Z2:Z" & lastrow).Value2
End With
Set wsTarget = ThisWorkbook.Sheets("TargetSheet")
n = 17
With wsTarget
For i = 1 To UBound(arNotCompl)
v = arNotCompl(i, 1)
If Application.WorksheetFunction.CountIf(.Range("B:B"), v) = 0 Then
.Cells(n, "B") = v
.Cells(n, "C").Formula = "=COUNTIF(SourceData!Z:Z,B" & n & ")"
n = n + 1
End If
Next
End With
End Sub

Create New Row in Sheet1 if Value in ((Sheet2, Column A) or (Sheet3, Column A)) Doesn't Exist in (Sheet 1, Column A)

I am trying to write a macro that will look in column A on sheet1 and see if it is missing any values from column A on sheet2 or column A on sheet3. If it is missing have the value added to the bottom of the column A on sheet1. The same value may exist on sheet2 and sheet3 but it only needs to be represented once on sheet1.
I'm working with the code below.
Sub newRow()
Dim rngSh1 As Range, rngSh2 As Range, rngSh3 As Range, mySelSh2 As Range, mySelSh3 As Range
Dim lastRowSh1 As Long, lastRowSh2 As Long, lastRowSh3 As Long
Dim wb As Worksheet
Dim cell As Range
Set wb = ThisWorkbook
With wb
lastRowSh1 = Worksheets("Sheet1").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh2 = Worksheets("Sheet2").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh3 = Worksheets("Sheet3").Range("A" & .Rows.Count).End(xlUp).Row
Set rngSh1 = Worksheets("Sheet1").Range("A1:A" & lastRowSh1)
Set rngSh2 = Worksheets("Sheet2").Range("A1:A" & lastRowSh2)
Set rngSh3 = Worksheets("Sheet3").Range("A1:A" & lastRowSh3)
End With
For Each cell In rngSh2.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh2 Is Nothing Then
Set mySelSh2 = cell
Else
Set mySelSh2 = Union(mySelSh2, cell)
End If
End If
Next cell
If Not mySelSh2 Is Nothing Then mySelSh2.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
For Each cell In rngSh3.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh3 Is Nothing Then
Set mySelSh3 = cell
Else
Set mySelSh3 = Union(mySelSh3, cell)
End If
End If
Next cell
If Not mySelSh3 Is Nothing Then mySelSh3.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
End Sub
I've made every adjustment I can think of but with every change I make I get a different error.
Any help would be greatly appreciated. Thanks!
Save yourself a little bit of time using a Scripting.Dictionary:
Option Explicit
Sub test()
Dim dict As New Scripting.dictionary, sheetNum As Long
For sheetNum = 2 To Sheets.Count
With Sheets(sheetNum)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rowNum As Long
For rowNum = 1 To lastRow
Dim dictVal As Long: dictVal = .Cells(rowNum, 1).Value
If Not dict.Exists(dictVal) Then dict.Add dictVal, 0
Next rowNum
End With
Next sheetNum
With Sheets(1)
Dim checkableRangeLastRow As Long: checkableRangeLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim checkableRange As Range: Set checkableRange = .Range(.Cells(1, 1), .Cells(checkableRangeLastRow, 1))
Dim dictKey As Variant
For Each dictKey In dict.Keys
If IsError(Application.Match(dictKey, checkableRange, 0)) = True Then
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastRow + 1, 1).Value = dictKey
End If
Next dictKey
End With
End Sub
You add all values in your not-master-sheet into dict then loop through that list; if it's not found in your master-sheet, then you add then to the end of the list.
A significant note is that the Type of value used as the dictVal may cause the IsError() statement to always be True if it is not the same Type as the data being assessed in the checkableRange.

Insert Row when 2 conditions are met

I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub

If column B value exists in column C then change the font of the string in column B to Bold

Part 1: Check if column B values exist in column C. If yes then change the font of the string in column B to Bold.
Part 2: I've used the code below and it worked well. Never tried it with 50k rows.
Sub matching()
LastRow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
For x = 1 To LastRow
'Column B = Username
If Sheet1.Range("B" & x).Font.Bold = True Then Sheet1.Range("A" & x).Value = "yay"
Next x
Application.ScreenUpdating = True
End Sub
If you have to handle too many rows, is better to use Dictionary to store values of column C & use Array to store values in column B.
Notes:
Add "Microsoft Scripting Runtime" reference (Tools - References - "Microsoft Scripting Runtime")
Dictionary is case sensitive.
You may need to change the sheet name in line Set ws = ThisWorkbook.Worksheets("Sheet1") to fulfill your needs
You could try:
Option Explicit
Sub matching()
Dim ws As Worksheet
Dim dict As Scripting.Dictionary
Dim LastRowB As Long, LastRowC As Long, Count As Long, x As Long
Dim rng As Range, cell As Range
Dim arr As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set dict = New Scripting.Dictionary
Application.ScreenUpdating = False
With ws
'Find the lastrow of column B
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
'Find the lastrow of column C
LastRowC = .Cells(.Rows.Count, "C").End(xlUp).Row
'Set an array with the values in column B - We assume that values start from row 1
arr = .Range("B1:B" & LastRowB)
'Set the range of the dicitonary - We assume that values start from row 1
Set rng = .Range("C1:C" & LastRowC)
Count = 0
'Loop range and create a dictionary with th eunique values
For Each cell In rng
If Not dict.Exists(cell.Value) Then
dict.Add Key:=cell.Value, Item:=Count
Count = Count + 1
End If
Next cell
'Loop the array & bold
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1)) Then
.Range("B" & x).Font.Bold = True
End If
Next x
End With
Application.ScreenUpdating = True
End Sub
Here you go.
Sub bold()
Dim lastrow As Double
Dim cel As Range
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For Each cel In Range("B1" & ":B" & lastrow)
If Not ActiveSheet.Range("C:C").Find(cel.Value) Is Nothing Then cel.Font.bold = True
Next cel
End Sub

Extract text from string based on value of a cell in another worksheet

I have a workbook with a series of sheets that I need to run a code to resolve the data.
I have one worksheet with a list of "codes" and another sheet that has cells that will include a string of codes.
I am trying to create a macro that allows me to reference a code in sheet1 A1, and then look through B:B in sheet2 and copy the row if the code appears in the string
I am a novice VBA user and have tried googling a few things and I'm not having any luck.
Edit:
I have managed to get something that does copy the data through, but there seems to be an issue in the For loop as all lines are copied in, not just the lines that match. Code below.
Private Sub CommandButton1_Click()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("MASTER LIST").UsedRange.Rows.Count
J = Worksheets("VALIDATED LIST").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("VALIDATED LIST").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("MASTER LIST").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = True
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = InStr(Worksheets("MASTER LIST").Range("E1:E" & I).Value, Worksheets("TRANSPOSED DATA NO SPACES").Range("B1:B" & J)) > 1 Then
xRg(K).EntireRow.Copy Destination:=Worksheets("VALIDATED LIST").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Further Edit:
I want to be able to use the list of feature codes and look them up in the master list.
If the VBA code finds the feature code in the strings in the master list, then I need to copy the row and paste it into a blank sheet that will be called validated list.
Sub look_up_copy()
Dim last_row As Integer
Dim cell As Range
Dim Cells As Range
last_row = ThisWorkbook.Worksheets(2).Cells(ThisWorkbook.Worksheets(2).Rows.Count, "B").End(xlUp).Row
Set Cells = ThisWorkbook.Worksheets(2).Range("B1:B" & last_row)
For Each cell In Cells:
If cell.Value = ThisWorkbook.Worksheets(1).Range("A1").Value Then
cell.EntireRow.Copy
End If
Next cell
End Sub
You didn't say anything about wanting to paste, but if you do then just insert it after the copy line.
this should work, just remove duplicates on sheet3 after running. This is a double loop in which, for each cell in column B of sheet 2, the macro will check all values from sheet1 Column A. You will see duplicate lines in the end, but it doesn't matter right? all you need is remove dupes
Sub IvanAceRows()
Dim cell2 As Range, cells2 As Range, cell1 As Range, cells1 As Range
Dim lastrow2 As Long, lastrow1 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, ii As Long, iii As Long
Set ws1 = Worksheets("USAGE CODES")
Set ws2 = Worksheets("MASTER LIST")
Set ws3 = Worksheets("VALIDATED LIST")
lastrow1 = ws1.cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = ws2.cells(Rows.Count, 2).End(xlUp).Row
Set cells1 = ws1.Range("A1:A" & lastrow1)
Set cells2 = ws2.Range("B1:B" & lastrow2)
iii = 1
For ii = 1 To lastrow2
For i = 1 To lastrow1
If InStr(1, ws2.cells(ii, 2), ws1.cells(i, 1)) <> 0 Then
ws2.cells(ii, 2).EntireRow.Copy
ws3.Activate
ws3.cells(iii, 1).Select
Selection.PasteSpecial
iii = iii + 1
End If
Next i
Next ii
End Sub
Without seeing your spreadsheet, I assumed all of your 'codes' are listed in Column A in sheet1, and all of those code strings are also in sheet2 in column B. my code allows u to find each string from sheet1 in Column B of sheet2. Once found, it will be pasted into Sheet3 starting from the 2nd row.
Sub IvanfindsRow()
Dim i As Long
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim Code As String
Dim search As Range
lastrow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Sheet3").Range("A1").Select
For i = 1 To lastrow1
Code = Worksheets("Sheet1").Cells(i, 1).Value
Set search = Worksheets("Sheet2").Range("B1:B22").Find(what:=Code, lookat:=xlWhole)
If Not search Is Nothing Then
search.EntireRow.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial
Else 'do nothing
End If
Next i
Application.CutCopyMode = False
End Sub

Resources