I was able to get this much working but not able to get it to start from Range("B12:B500").
Sub findTwoEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To lastRow
If Cells(i, 1).Value = "" And Cells(i, 1).Offset(1, 0).Value = "" Then
Set firstEmptyCell = Cells(i, 1)
Exit For
End If
Next i
End If
firstEmptyCell.Value = "x"
End Sub
Thanks to #Dominique & #FaneDuru, i was able to get the result as per the below by combining both their ideas :
Sub findTwoEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 12).End(xlUp).Row
For i = 12 To lastRow
If Cells(i, 2).Value = "" And Cells(i + 1, 1).Value = "" Then
Set firstEmptyCell = Cells(i, 1)
Exit For
End If
Next i
If firstEmptyCell Is Nothing Then
MsgBox ("There are no two empty cells in a row")
Exit Sub
End If
firstEmptyCell.Value = "x"
End Sub
Related
Problem:
I am working on the "Extract" workbook and expect to copy some data from the "Sales2021" workbook which is closed. The point is: when I have 2 workbooks open, the code works perfectly but when I close "Sales2021", it runs into error. My purpose is to modify the script so that even when "Sales2021" is closed, it still works.
Code explanations:
"Extract" contains 2 sheets, sheet1 and sheet2 (sheet2 is the destination sheet where I want to copy data from "Sales2021" to). "Sales2021" has only "Master_data" sheet. I want to check whether cells (1,2) and (1,3) of sheet1 match data in column 2 and 3 of "Master_data".
Sub Extract()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in Column A
With Workbooks("Sales2021.xlsm").Sheets("Master_data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Copy headers
Worksheets("Extract").Rows(1).Value = Workbooks("Sales2021.xlsm").Sheets("Master_data").Rows(1).Value
'first row number'
With Worksheets("Sheet2")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Workbooks("Sales2021.xlsm").Sheets("Master_data")
If (.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And .Cells(i, 3).Value = Worksheets("Sheet1").Cells(1, 2).Value) Or (.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And Worksheets("Sheet1").Cells(1, 2).Value = "") Then
.Rows(i).Copy Destination:=Worksheets("Sheet2").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
I haven't really tested this. The code checks if the workbooks is already open and opens it if needed.
Public Sub Extract()
Const EXPECTED_PATH As String = "C:\Users\Laura\Test\Sales2021.xlsm.xlsx"
'Check if the file is already open, if it isn't then open it.
Dim ReportBk As Workbook
Dim wrkBk As Workbook
For Each wrkBk In Application.Workbooks
If wrkBk.FullName = EXPECTED_PATH Then
Set ReportBk = wrkBk
Exit For
End If
Next wrkBk
If wrkBk Is Nothing Then
Set ReportBk = Workbooks.Open(EXPECTED_PATH)
End If
Dim Source_LastRow As Long
With ReportBk.Worksheets("Master_data")
Source_LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Extract").Rows(1).Value = .Rows(1).Value
End With
Dim Target_LastRow As Long
With ThisWorkbook.Worksheets("Sheet2")
Target_LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With ReportBk.Worksheets("Master_data")
Dim i As Long
For i = 1 To Source_LastRow
If (.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And _
.Cells(i, 3).Value = Worksheets("Sheet1").Cells(1, 2).Value) Or _
(.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And _
Worksheets("Sheet1").Cells(1, 2).Value = "") Then
.Rows(i).Copy Destination:=Worksheets("Sheet2").Cells(Target_LastRow, 1)
Target_LastRow = Target_LastRow + 1
End If
Next i
End With
End Sub
I am getting a subscript out of range error on the first if statement.
I had this working when it was all within the same Workbook just different sheets
I want it to reference a different workbook to gets it data from.
I did the tools -> reference -> "Report" workbook that way I know it is open.
Sub update_cell1_InProcess()
Dim lRow As Long
b = 31
lRow = Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 5).Value = Workbooks("Big screen.xlsm").Sheets("CELL_1").Cells()(1, 2).Value Then 'B1
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 1).Value = Workbooks("Big screen.xlsm").Sheets("CELL_1").Cells()(1, 1).Value Then 'A1
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 6).Value <> "" Then 'not blank
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 8).Value = "" Then
Workbooks("Report.xlsm").Sheets("CopyDatabase").Rows(i).Copy
Workbooks("Big screen.xlsm").Sheets("SHEET1").Activate
Workbooks("Big screen.xlsm").Sheets("SHEET1").Cells(b + 1, 1).Select
ActiveSheet.Paste
b = b + 1
End If
End If
End If
End If
Next
Application.CutCopyMode = False
End Sub
Just different If statements but code that worked in same workbook different sheets
Sub update_cell1_completed()
Dim lRow As Long
b = 1
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If Worksheets("TEST").Cells(i, 5).Value = Worksheets("CELL_1").Cells()(1, 2).Value Then 'B1
If Worksheets("TEST").Cells(i, 1).Value = Worksheets("CELL_1").Cells()(1, 1).Value Then 'A1
If Worksheets("TEST").Cells(i, 6).Value <> "" Then 'not blank
If Worksheets("TEST").Cells(i, 8).Value <> "" Then 'not blank
Worksheets("TEST").Rows(i).Copy
Worksheets("SHEET1").Activate
Worksheets("SHEET1").Cells(b + 1, 1).Select
ActiveSheet.Paste
b = b + 1
End If
End If
End If
End If
Next
Application.CutCopyMode = False
End Sub
Here's your code refactored to include proper object references and simply the multi-if statement. See if you get the same error, and if so, let us know which line is erroring for you:
EDIT: Per comments, updated references to Workbooks("Big screen.xlsm") to instead be ThisWorkbook
Sub update_cell1_InProcess()
Dim wbRprt As Workbook: Set wbRprt = Workbooks("Report.xlsm")
Dim wbScrn As Workbook: Set wbScrn = ThisWorkbook
Dim wsDB As Worksheet: Set wsDB = wbRprt.Worksheets("CopyDatabase")
Dim wsC1 As Worksheet: Set wsC1 = wbScrn.Worksheets("CELL_1")
Dim wsS1 As Worksheet: Set wsS1 = wbScrn.Worksheets("SHEET1")
Dim lLastRow As Long: lLastRow = wsDB.Cells(wsDB.Rows.Count, "A").End(xlUp).Row
Dim lDestRow As Long: lDestRow = 32
Dim i As Long
For i = 1 To lLastRow
If wsDB.Cells(i, "E").Value = wsC1.Range("B1").Value _
And wsDB.Cells(i, "A").Value = wsC1.Range("A1").Value _
And Len(wsDB.Cells(i, "F").Value) > 0 _
And Len(wsDB.Cells(i, "H").Value) > 0 Then
wsDB.Rows(i).Copy wsS1.Cells(lDestRow, "A")
lDestRow = lDestRow + 1
End If
Next i
Application.CutCopyMode = False
End Sub
Here is my Sheet in which i wrote this code
Sub L()
Dim rng As Range, cell As Range
Set rng = Range("P12:P1322")
For Each cell In rng
If cell.Value > 12 Then
cell.Interior.ColorIndex = 3
ActiveCell.Range(rng).Activate
Copy.selection
Range(rng).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrAbove
'Range(rng).Offset(1).EntireRow.PasteSpecial xlPasteFormats
End If
Next cell
End Sub
I tried another code too but it was not working.
You see the red cells These cells value is greater than 12 I want to add the row with same formatting below the active row.
I think this should do what you want
Sub L()
Dim i As Long
With Range("P12:P1322")
For i = .Rows.Count To 12 Step -1
If .Cells(i, 1).Value > 12 Then
.Cells(i, 1).Interior.ColorIndex = 3
.Cells(i + 1, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
End With
End Sub
The following is significantly faster
Sub LImproved()
Dim dStart As Double
dStart = Timer
Dim i As Long
Dim lCol As Long: lCol = 16 ' column P
Dim lLastRow As Long
Dim sRows As String
With ThisWorkbook.Sheets("Sheet1")
lLastRow = .Cells(.Rows.Count, lCol).End(xlUp).Row
'lLastRow = 1322
For i = lLastRow To 12 Step -1
If .Cells(i, lCol).Value > 12 Then
sRows = sRows & i + 1 & ":" & i + 1 & ","
If Len(sRows) > 235 Then
UpdateFormats Left(sRows, Len(sRows) - 1), lCol
sRows = ""
End If
End If
Next i
If sRows <> "" Then UpdateFormats Left(sRows, Len(sRows) - 1), lCol
End With
MsgBox "Time taken: " & Format(Timer - dStart, "0.00s")
End Sub
Sub UpdateFormats(sRows As String, lCol As Long)
With ThisWorkbook.Sheets("Sheet1")
With Intersect(.Range(sRows), .Columns(lCol)).Offset(-1, 0)
.Interior.ColorIndex = 3
End With
With .Range(sRows)
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End With
End With
End Sub
I trying to write a code where I want to look select range from Start to End in column A then fill the selected range in Column B with '1'. But my code only fill up bottom parts and missed out top parts. Refer to this photo. How do i make sure it go through every row and when it encounter Start, it will look for nearest End and fill up column B?
Sub Select()
Dim LastRowA As Long, i As Long
Dim findrow As Long, findrow2 As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
findrow = Range("A:A").Find("Start", Range("A1")).Row
findrow2 = Range("A:A").Find("End", Range("A" & findrow)).Row
Range("A" & findrow & ":A" & findrow2).Offset(0, 1).Value = "1"
Next i
End With
End Sub
This will find Start, loop through until it finds End. Tested and working as requested.
Sub Select()
Dim LastRowA, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
If .Cells(i, 1) = "Start" Then
Do Until .Cells(i, 1) = "End"
.Cells(i, 2).Value = 1
i = i + 1
Loop
.Cells(i, 2).Value = 1
End If
Next i
End With
End Sub
Find is a precarious beast to use in VBA. It would be far simpler to just loop through the cells, keeping track of whether or not you're between Start and End:
Sub Select()
Dim LastRowA As Long, i As Long, b As Boolean
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
If .Cells(i, 1).Value = "Start" Then
b = True
.Cells(i, 2).Value = 1
ElseIf .Cells(i, 1).Value = "End" Then
b = False
.Cells(i, 2).Value = 1
ElseIf b Then
.Cells(i, 2).Value = 1
End If
Next i
End With
End Sub
I have a piece of code that worked for part but took ages to run (about 1700 rows). When I updated it to perform the whole function it now doesn't do anything- not sure where Ive gone wrong, and is there a version of code that would be quicker?
I'm still very new so do my code by searching what I want to do then bending it to suit.
I would like to check in column I for all dates that are less than the date in cell Z1. If any cells in the corresponding row say "Issued" I would like it to change to "Overdue".
Sub updateoverdue()
Application.ScreenUpdating = True
Dim j As Long, i As Long, lastRow1 As Long, lastRow2 As Long
Dim sh_1, sh_3 As Worksheet
Set sh_1 = Sheet6
Set sh_3 = Sheet6
lastRow1 = sh_1.UsedRange.Rows.Count
For j = 2 To lastRow1
Sheet6.Range("z1") = sh_1.Cells(j, 9).Value
lastRow2 = sh_3.UsedRange.Rows.Count
For i = 2 To lastRow2
If sh_3.Cells(i, 9).Value < Sheet6.Range("z1") And sh_3.Cells(i, 10).Value = "Issued" Then
sh_3.Cells(i, 10).Value = "Overdue"
End If
Next i
Next j
Application.ScreenUpdating = True
End Sub
I got it working on just Column J but then it failed when I added in the Issued part. Plus I cant get it to change more than one column (J to W).
Something like this might work for you:
Sub tgr()
Dim ws As Worksheet
Set ws = Sheet6
Dim TargetDate As Date
TargetDate = ws.Range("Z1").Value2
Dim DateList As Range
Set DateList = ws.Range("I2", ws.Cells(ws.Rows.Count, "I").End(xlUp))
If DateList.Row < 2 Then Exit Sub 'No dates
Dim DateCell As Range
For Each DateCell In DateList.Cells
If DateCell.Value2 > TargetDate And LCase(Trim(DateCell.Offset(, 1).Value)) = "issued" Then
DateCell.Offset(, 1).Value = "Overdue"
End If
Next DateCell
End Sub
I tested this and it worked fine:
Sub try()
Dim ws As Worksheet, lastrow As Long
Set ws = Sheet6
lastrow = ws.Cells(Rows.Count, 9).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To lastrow
If ws.Cells(i, 9).Value < ws.Cells(1, 26).Value Then
ws.Cells(i, 10).Value = "Overdue"
ElseIf ws.Cells(i, 9).Value > ws.Cells(1, 26).Value Then
ws.Cells(i, 10).Value = "Issued"
Else
ws.Cells(i, 10).Value = "Due Today"
End If
Next i
Application.ScreenUpdating = True
End Sub
Or you can just use an excel formula and drop it down the entire column:
=IF(I1<$Z$1, "Issued","Overdue")