VBA Create row below based on two criteria - excel

I am having a hard time getting the below logic to work. The issue seems to be where the Year function is placed. It seems to be skipping over the logic completely, yet i'm not sure how to encorporate the year function without breaking the with loop.
Sub BlankLine()
Dim Col_year As Variant
Dim Col_st As Variant
Dim Col_btc As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim ws As Worksheet
Dim wb As Workbook
Dim state_ar() As Variant
Col_year = "E"
Col_st = "C"
Col_btc = "D"
StartRow = 1
BlankRows = 1
Set wb = ThisWorkbook
Set ws = wb.Worksheets("LU_WK_BENE_AMT")
LastRow = ws.Cells(Rows.Count, Col_year).End(xlUp).Row
Application.ScreenUpdating = False
state_ar = Array("02", "03")
For Each State In state_ar
With ws
For R = LastRow To StartRow + 1 Step -1
If Year(.Cells(R, Col_year).Value) = 2020 And .Cells(R, Col_st) = i Then
.Cells(R + 1, Col_year).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col_year).Value = 2021
.Cells(R + 1, Col_st).Value = .Cells(R, Col_st).Value
.Cells(R + 1, Col_btc).Value = .Cells(R, Col_btc).Value
End If
Next R
End With
Next
Application.ScreenUpdating = True
End Sub

Related

VBA code only works when I run it steps by steps(F8)

I have a code when runs perfectly by hitting F8 (running steps by steps). However, it doesn't work when hitting F5(running it). I guess it's because my code is kind of in loop but I couldn't figure out what's wrong.
Sub BLKReport()
Dim IRow As Long
Dim lcntr As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim b As Long
Dim r As String
Dim i As Long
Set ws = ThisWorkbook.Worksheets("CSV File")
Set ws1 = ThisWorkbook.Worksheets("Destination")
lrow = Range("A2").End(xlDown).Row
For lcntr = lrow To 1 Step -1
If ws.Cells(lcntr, 9).Value = "25" Then
r = ws.Cells(lcntr, 2).Value
For i = lcntr To 1 Step -1
If ws.Cells(i, 2).Value = r Then
ws.Rows(i).Copy
ws1.Activate
b = i
ws1.Cells(b - 1, 1).Select
ActiveSheet.Paste
ws.Activate
ElseIf ws.Cells(i + 1, 1).Value <> r Then
End If
Next i
End If
Application.CutCopyMode = False
ws.Select
Next
End Sub

VBA loop to take value if field is blank

Need some solution in VBA ->If the blank value in column A then takes value from column B.
I wrote some code, but I don't have any idea why this is not working.
dim LastR as Long
LastR = Worksheets("Sheet1").Range("BU" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
dim i as long
For i = LastR To 2 Step -1
If IsEmpty(Cells(i, "a")) Then Cells(i, "a").Value = Cells(i, "b").Value
Next i
You should check if the value is empty.
See two examples:
Dim LastR As Long
LastR = Worksheets("Sheet1").Range("BU" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
Dim i As Long
For i = LastR To 2 Step -1
'If Sheets("Sheet1").Cells(i, "a") = "" Then Sheets("Sheet1").Cells(i, 1).Value = Cells(i, 2).Value
If IsEmpty(Sheets("Sheet1").Cells(i, "a").Value) = True Then Sheets("Sheet1").Cells(i, 1).Value = Cells(i, 2).Value
Next i
Loop Through the Cells of a Column
All three versions do the same and are about equally efficient.
Option Explicit
Sub FillEmptiesConstants()
Const wsName As String = "Sheet1" ' Worksheet Name
Const fRow As Long = 2 ' First Row
Const lrCol As String = "BU" ' Last Row Column
Const lCol As String = "A" ' Lookup Column
Const dCol As String = "A" ' Destination Column
Const sCol As String = "B" ' Source Column
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
If lRow < fRow Then Exit Sub
Dim r As Long
For r = fRow To lRow
If IsEmpty(ws.Cells(r, lCol)) Then
ws.Cells(r, dCol).Value = ws.Cells(r, sCol).Value
End If
Next r
End Sub
Sub FillEmptiesSimple()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "BU").End(xlUp).Row
If lRow < 2 Then Exit Sub
Dim r As Long
For r = 2 To lRow
If IsEmpty(ws.Cells(r, "A")) Then
ws.Cells(r, "A").Value = ws.Cells(r, "B").Value
End If
Next r
End Sub
Sub FillEmptiesSimpleWith()
With ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long: lRow = .Cells(.Rows.Count, "BU").End(xlUp).Row
If lRow < 2 Then Exit Sub
Dim r As Long
For r = 2 To lRow
If IsEmpty(.Cells(r, "A")) Then
.Cells(r, "A").Value = .Cells(r, "B").Value
End If
Next r
End With
End Sub

Duplicate row if a cell within a column contains text, then move values from one column to another?

I am trying to build a macro that goes through my data set and checks if there's any text in column W, if it does I would like the macro to duplicate the row beneath it, then move the values from Columns X and W to U and Q respectively.
My code at the moment is only trying to get the duplicate part down but its not working and I'm kind of stuck, could you have a look at it and help out?
Dim lastRow2 as Long
Dim cel as Range, srchRng as Range
lastRow2 = Worksheets("UPLOAD COPY").Cells(Rows.Count, 23).End(xlUp).Row
Set srchRng = Range("W2: W" & lastRow2)
For Each cel In srchRng
If InStr(1, cel.Value, "*") > 0 Then
cel.Offset(1).Insert
cel.EntireRow.Copy cel.Offset(1)
Set cel = cel.Offset(2)
End If
Next cel
Create Duplicate Rows
Option Explicit
Sub createDuplicateRows()
Const wsName As String = "UPLOAD COPY"
Const FirstRow As Long = 2
Const Col As Variant = "W" ' or 23
Dim OldCols As Variant: OldCols = Array("W", "X") ' or 23, 24
Dim NewCols As Variant: NewCols = Array("Q", "U") ' or 17, 21
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim CurrentRow As Long: CurrentRow = FirstRow
Dim j As Long
Do
If ws.Cells(CurrentRow, Col).Value <> "" Then GoSub insertRow
CurrentRow = CurrentRow + 1
Loop Until CurrentRow > LastRow
Exit Sub
insertRow:
ws.Rows(CurrentRow + 1).EntireRow.Insert Shift:=xlDown
ws.Rows(CurrentRow).EntireRow.Copy ws.Rows(CurrentRow + 1)
CurrentRow = CurrentRow + 1
GoSub changeValues
LastRow = LastRow + 1
Return
changeValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, NewCols(j)).Value _
= ws.Cells(CurrentRow, OldCols(j)).Value
ws.Cells(CurrentRow, OldCols(j)).ClearContents
Next j
Return
End Sub
EDIT:
You can write the 'delete part' in a separate subroutine. Then you can do what I suggested in the comments. Sorry, I didn't realize that previously it would copy the already cleared (empty) values.
Option Explicit
Sub createDuplicateRows()
Const wsName As String = "UPLOAD COPY"
Const FirstRow As Long = 2
Const Col As Variant = "W" ' or 23
Dim OldCols As Variant: OldCols = Array("W", "X", "X") ' or 23, 24, 24
Dim NewCols As Variant: NewCols = Array("Q", "U", "Y") ' or 17, 21, 25
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim CurrentRow As Long: CurrentRow = FirstRow
Dim j As Long
Do
If ws.Cells(CurrentRow, Col).Value <> "" Then GoSub insertRow
CurrentRow = CurrentRow + 1
Loop Until CurrentRow > LastRow
Exit Sub
insertRow:
ws.Rows(CurrentRow + 1).EntireRow.Insert Shift:=xlDown
ws.Rows(CurrentRow).EntireRow.Copy ws.Rows(CurrentRow + 1)
CurrentRow = CurrentRow + 1
GoSub changeValues
LastRow = LastRow + 1
Return
changeValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, NewCols(j)).Value _
= ws.Cells(CurrentRow, OldCols(j)).Value
Next j
GoSub deleteValues
Return
deleteValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, OldCols(j)).ClearContents
Next j
Return
End Sub

VBA. Deleting multiple cells in a row if one cell is blank

I have multiple columns in an excel sheet...say A1:D10.
I want to find any blank cells in column C, delete that cell as well as the A,B, and D cells of that same row, then shift up. But only in the range of A1:D10. I have other information in this excel sheet outside this range that I want to perserve in its original position. Therefore I can not use somthing like this:
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Nor can I get something like the following to work, because it only shifts the single column up, not all four columns.
Set rng = Range("A1:D10").SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp
If there is no data in columns A to D below row 10 that you don't want to move up, then SpecialCells and Delete Shift Up can be used like this
Sub Demo1()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
Dim rng As Range, arr As Range
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
On Error Resume Next
Set rng = .Range(.Cells(FirstRow, TestColumn), .Cells(LastRow, TestColumn)).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
For Each arr In rng.Areas
arr.EntireRow.Resize(, EndColumn - StartColumn + 1).Delete Shift:=xlShiftUp
Next
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
If there is data in columns A to D below row 10 that you don't want to move up, then you can use Cut and Paste, like this
Sub Demo()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
If IsEmpty(.Cells(LastRow, TestColumn)) Then
.Cells(LastRow, StartColumn).Resize(1, EndColumn - StartColumn + 1).Clear
End If
For i = LastRow - 1 To FirstRow Step -1
If IsEmpty(.Cells(i, TestColumn)) Then
.Range(.Cells(i + 1, StartColumn), .Cells(LastRow, EndColumn)).Cut .Cells(i, StartColumn)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Using Variant Array Method
Sub test2()
Dim rngDB As Range, vDB As Variant
Dim i As Integer, j As Integer, n As Integer
Dim k As Integer
Set rngDB = Range("a1:d10")
vDB = rngDB
n = UBound(vDB, 1)
For i = 1 To n
If IsEmpty(vDB(i, 3)) Then
For j = 1 To 4
If j <> 3 Then
vDB(i, j) = Empty
End If
Next j
End If
Next i
For j = 1 To 4
If j <> 3 Then
For i = 1 To n - 1
For k = i To n - 1
If vDB(k, j) = Empty Then
vDB(k, j) = vDB(k + 1, j)
vDB(k + 1, j) = Empty
End If
Next k
Next i
End If
Next j
rngDB = vDB
End Sub
The below will take care of your requirement by looking for an empty cell in column 3, and deleting the row and shifting up only in that row.
Sub deleteEmptyRow()
Dim i As Integer
For i = 1 To 10
If Cells(i, 3) = "" Then
Range(Cells(i, 1), Cells(i, 4)).delete Shift:=xlUp
End If
Next i
End Sub

Comparing two workbooks with 80 sheets each

I am trying to write a script that will compare two workbooks that each have 80 sheets. The sheet names will match in both workbooks (one workbook is a prod copy, one is a copy from a UAT environment. All data should be same). I was able to run a script that will compare the sheet I specify, but I'm having difficulty trying to figure out how to write it to compare each sheet.
Sub CompareWorksheets()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim varSheetAr As Variant
Dim varSheetBr As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim wbkc As Workbook
Set wbkc = ThisWorkbook 'this is where results of comparison will be documented
Set wbka = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbkb = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
Set varSheetA = wbka.Worksheets("Members")
Set varSheetB = wbkb.Worksheets("Members")
strRangeToCheck = ("A5:A10")
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
erow = 6 'starting row to document summary results
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
wbkc.Sheets("Summary").Cells(erow, 2) = iRow
wbkc.Sheets("Summary").Cells(erow, 3) = iCol
wbkc.Sheets("Summary").Cells(erow, 4) = varSheetA.Cells(iRow, iCol)
wbkc.Sheets("Summary").Cells(erow, 5) = varSheetB.Cells(iRow, iCol)
End If
Next
Next
End Sub
You need to iterate through the Worksheets of one of the workbooks and use the worksheet names to set worksheet variable for the second workbook.
Sub CompareWorksheets()
Dim wbPROD As Workbook, wbUAT As Workbook, wbSummary As Workbook
Dim wsPROD As Worksheet, wsUAT As Worksheet, wsSummary As Worksheet
Dim arrPROD As Variant, arrUAT As Variant
Dim strRangeToCheck As String
Dim iRow As Long, iCol As Long
Set wbSummary = ThisWorkbook 'this is where results of comparison will be documented
Set wsSummary = wbkc.Sheets("Summary")
Set wbPROD = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbUAT = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
strRangeToCheck = ("A5:A10")
erow = 6 'starting row to document summary results
For Each wsPROD In wbPROD.Worksheets
Set wsUAT = wbUAT.Worksheets(wsPROD.Name)
arrPROD = wsPROD.Range(strRangeToCheck).Value
arrUAT = wsUAT.Range(strRangeToCheck).Value
For iRow = LBound(arrPROD, 1) To UBound(arrPROD, 1)
For iCol = LBound(arrPROD, 2) To UBound(arrPROD, 2)
If arrPROD(iRow, iCol) = arrUAT(iRow, iCol) Then
wsPROD.Cells(iRow, iCol).Interior.ColorIndex = xlNone
wsUAT.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
wsPROD.Cells(iRow, iCol).Interior.ColorIndex = 22
wsUAT.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
With wsSummary
.Cells(erow, 2) = iRow
.Cells(erow, 3) = iCol
.Cells(erow, 4) = wsPROD.Cells(iRow, iCol)
.Cells(erow, 5) = wsUAT.Cells(iRow, iCol)
End With
End If
Next
Next
Next
End Sub
Start with
Option Explicit ' to force you to declare for each variable
Add code to delete prior errors
Dim wbkc As Workbook, LastRow as Long, nRow as Long
wbkc.Sheets("Summary").UsedRange 'Refresh UsedRange
LastRow = wbkc.Sheets("Summary").UsedRange.Rows(wbkc.Sheets("Summary").UsedRange.Rows.Count).Row
For nRow = LastRow to eRow + 1 step -1
wbkc.Sheets("Summary").Rows(nRow).Delete
Next nRow
Basically, google "excel vba for each sheet" and look at the first one
https://stackoverflow.com/questions/21918166/excel-vba-for-each-worksheet-loop
to get the driving code (ignoring resizingColumns) and create CompareCells.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call CompareCells(ws)
Next
End Sub
Sub CompareCells(ws as Worksheet)
End Sub
Finally, Add your code inside of CompareCells
Giving (PLEASE test this code, since we do not have wbka or wbkb excel files)
Option Explicit ' to force you to declare for each variable
' define output -- this is where results of comparison will be documented
Dim wbkc As Workbook, eRow as long, LastRow as Long, nRow as Long
Set wbkc = ThisWorkbook
eRow = 6 'starting row to document summary results
wbkc.Sheets("Summary").UsedRange 'Refresh UsedRange
LastRow = wbkc.Sheets("Summary").UsedRange.Rows(wbkc.Sheets("Summary").UsedRange.Rows.Count).Row
For nRow = LastRow to eRow + 1 step -1
wbkc.Sheets("Summary").Rows(nRow).Delete ' delete prior errors
Next nRow
' define inputs --
Dim wbka As Workbook, wbkb As Workbook
Set wbka = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbkb = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
' step thru each sheet
Dim ws As Worksheet
For Each ws In wbka.Worksheets
'
Dim varSheetA As Worksheet, varSheetB As Worksheet
Dim varSheetAr As Variant, varSheetBr As Variant
Dim strRangeToCheck As String
Set varSheetA = wbka.Worksheets(ws.Name)
Set varSheetB = wbkb.Worksheets(ws.Name)
strRangeToCheck = ("A5:A10")
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
' step thru each cell
Dim iRow As Long, iCol As Long
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
wbkc.Sheets("Summary").Cells(erow, 1) = ws.Name 'ADDed
wbkc.Sheets("Summary").Cells(erow, 2) = iRow
wbkc.Sheets("Summary").Cells(erow, 3) = iCol
wbkc.Sheets("Summary").Cells(erow, 4) = varSheetA.Cells(iRow, iCol)
wbkc.Sheets("Summary").Cells(erow, 5) = varSheetB.Cells(iRow, iCol)
End If
Next iCol
Next iRow
Next ws

Resources