I'm attempting to create a macro that performs a check on a range that if a cell is formatted as red (based on conditional formatting) then stop the sub... otherwise continue.
Sub O_Upload()
' Keyboard Shortcut: Ctrl+Shift+U
Dim Wb1 As Workbook, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet,
wbactive As Workbook, wsactive As Worksheet, lstrow As Long
Set Wb1 = Workbooks("spreadsheet.xlsx")
Set ws1 = Wb1.Sheets("Stage 1 Trim")
Set ws2 = Wb1.Sheets("Stage 2 Data Validation")
Set ws3 = Wb1.Sheets("_1010u Sheet")
Set wbactive = ActiveWorkbook
Set wsactive = wbactive.Sheets("Data")
wsactive.range("B10").Select
lstrow = Selection.End(xlDown).Row
wsactive.range("A10:V" & lstrow).Copy Destination:=ws1.range("A4")
ws1.range("X4:AS" & lstrow).Copy
ws2.range("A3").PasteSpecial xlPasteValues
'add red validation check
'if red stop
'if green copy to ws3
Dim cel As range
For Each cel In ws2.range("A3:V" & lstrow)
If cel.Interior.Color = RGB(255, 0, 0) Then
MsgBox ("Data contains errors!"), vbOKOnly
Exit Sub
End If
Next
ws2.range("A3:V" & lstrow).Copy
ws3.range("B13").PasteSpecial xlPasteValues
MsgBox "Data is ready to be uploaded", vbOKOnly
End Sub
The error i'm getting is on line -For Each cel In ws2.range("A3:V" & lstrow)
I appreciate the help.
Attributing my other answer for details.
Kindly replace the code
cel.Interior.Color
with this:
cel.DisplayFormat.Interior.Color
Related
i have this code:
Sub reportCreation()
Dim sourceFile As Variant
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim sourceSheet As Worksheet
Dim destSheet As Worksheet
Dim rng As Range
Dim i As Long
Dim NValues As Long
If sourceFile = False Then
MsgBox ("Select the MyStats file that you want to import to this report")
sourceFile = Application.GetOpenFilename
Set wbSource = Workbooks.Open(sourceFile)
Set sourceSheet = wbSource.Sheets("Test Dummy Sheet")
Set rng = sourceSheet.Range("A:N")
rng.Copy
Set wbDest = ThisWorkbook
Set destSheet = wbDest.Sheets("MyStats")
destSheet.Range("A1").PasteSpecial
Application.CutCopyMode = False
wbSource.Close
End If
NValues = destSheet.Cells(destSheet.Rows.Count, 2).End(xlUp).Row
With destSheet
For i = 6 To NValues
' Cells(i, 3).NumberFormat = "0"
With Cells(i, 3)
.Value = Cells.Value / 1000000
.NumberFormat = "0.00"
End With
Next i
End With
End Sub
the code runs fine for the IF Statement part which is a simple cop and paste sort of scenario but then once the WS has been copied to the new WB i need column 3 to devide any cell in that is larger than 1M by 1M and as soon as the code finds the first cell with a value of over 1M i get an error message "Runtime Error 7, system out of memory" but i still have 2GB left of memory so this does not seem to be your tipycal out of mem issue where i need to close a few applications and it will run because it just does not.
i am wondering if there is an issue with my code?
some of the sample values that the code will look are:
16000000
220000
2048000
230000
16000000
230000
16000000
you may want to adopt a different approach like follows (see comments)
Option Explicit
Sub reportCreation()
Dim sourceFile As Variant
Dim sourceSheet As Worksheet
Dim tempCell As Range
sourceFile = Application.GetOpenFilename(Title:="Select the MyStats file that you want to import to this report", _
FileFilter:="Excel Files *.xls* (*.xls*),") '<-- force user to select only excel format files
If sourceFile = False Then Exit Sub '<-- exit if no file selected
Set sourceSheet = TryGetWorkSheet(CStr(sourceFile), "Test Dummy Sheet") '<-- try and get the wanted worksheet reference in the chosen workbook
If sourceSheet Is Nothing Then Exit Sub '<-- exit if selected file has no "Test Dummy Sheet" sheet
With sourceSheet '<-- reference your "source" worksheet
Intersect(.UsedRange, .Range("A:N")).Copy
End With
With ThisWorkbook.Sheets("MyStats") '<-- reference your "destination" worksheet
.Range("A1").PasteSpecial
Application.CutCopyMode = False
sourceSheet.Parent.Close
Set tempCell = .UsedRange.Cells(.UsedRange.Rows.Count + 1, .UsedRange.Columns.Count) '<-- get a "temporary" cell not in referenced worksheet usedrange
tempCell.Value = 1000000 'set its value to the wanted divider
tempCell.Copy ' get that value into clipboard
With .Range("C6:C" & .Cells(.Rows.Count, 2).End(xlUp).Row) '<-- reference cells in column "C" from row 6 down to last not empty one in column "B"
.PasteSpecial Paste:=xlValues, Operation:=xlPasteSpecialOperationDivide '<-- divide their values by clipboard content
.NumberFormat = "0.00" '<-- set their numberformat
End With
tempCell.ClearContents '<-- clear the temporary cell
End With
End Sub
Function TryGetWorkSheet(wbFullName As String, shtName As String) As Worksheet
On Error Resume Next
Set TryGetWorkSheet = Workbooks.Open(wbFullName).Sheets("Test Dummy Sheet")
End Function
I believe I have everything else figured out but the line Set newSheetName = sht.Range("A1:A") is not pulling any information. I am getting the Run-time error '1004': Method 'Range' of object'_Worksheet' failed. What am I missing?
What I am trying to achieve is for this macro to look at the range in sheet "ARK_E_TEXAS" which is A1 through C23("ARK_E_TEXAS_LIST"). If A1:A has data it will create a new sheet and name that new sheet with the cell name. I am using the Lastrow line to know how many lines to go down and the if function to skip over the blanks.
Sub Create_ARK_E_TEXAS()
Dim sht As Worksheet
Dim newSheetName As Range
Dim dataRange As Range
Dim Lastrow As Long
Set sht = ThisWorkbook.Sheets("ARK_E_TEXAS")
Set newSheetName = sht.Range("A1:A")
Lastrow = sht.Range("ARK_E_TEXAS_LIST").Rows.Count
Set dataRange = sht.Range("A1:C" & Lastrow)
For Each newSheetName In dataRange
If newSheetName.Value <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = newSheetName.Value ' renames the new worksheet
End If
Next newSheetName
End Sub
Ok I got my answer with the help of #AlexWeber.
Sub Create_ARK_E_TEXAS()
Dim sht As Worksheet
Dim newSheetName As Range
Dim dataRange As Range
Dim Lastrow As Long
Set sht = ThisWorkbook.Sheets("ARK_E_TEXAS")
Lastrow = sht.Range("ARK_E_TEXAS_LIST").Rows.Count
Set newSheetName = sht.Range("A1:A" & Lastrow)
Set dataRange = sht.Range("A1:A" & Lastrow)
For Each newSheetName In dataRange
If newSheetName.Value <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = newSheetName.Value ' renames the new worksheet
End If
Next newSheetName
End Sub
I have three ranges in a sheet (rng1, rng2, rng3) where I need to make sure that rng2 and rng3 contain no blanks before proceeding with the macro.
I have tried several methods that I can find and cannot get any of them to work. Willing to try a different method if someone has suggestions.
This is me trying to count blank cells using specialcells(xlCellTypeBLanks) but something isn't working with my error handling when neither range is blank:
Dim wrk As Workbook
Dim sht As Worksheet
Dim twb As Workbook
Dim tws As Worksheet
Dim lrow As Long
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim finprod As Variant
Dim subprod As Variant
Application.ScreenUpdating = False
Set wrk = ActiveWorkbook
Set sht = wrk.Worksheets(1)
For Each sht In wrk.Worksheets
lrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = sht.Range("A2:A" & lrow)
Set rng2 = sht.Range("F2:F" & lrow)
Set rng3 = sht.Range("E2:E" & lrow)
On Error GoTo Err1
If rng3.SpecialCells(xlCellTypeBlanks).Count > 0 Then
MsgBox ("Invalid item number.")
Exit Sub
End If
Err1:
On Error GoTo Err2
If rng2.SpecialCells(xlCellTypeBlanks).Count > 0 Then
MsgBox ("Missing quantity.")
Exit Sub
End If
Err2:
On Error GoTo 0
Exit For
Next sht
I try to avoid using goto in such way - it makes the code confusing when it gets bigger. Here is what I came up with:
Sub check_blank()
Dim sht As Worksheet
Dim twb As Workbook
Dim tws As Worksheet
Dim lrow As Long
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim finprod As Variant
Dim subprod As Variant
Application.ScreenUpdating = False
Set wrk = ActiveWorkbook
Set sht = wrk.Worksheets(1)
For Each sht In wrk.Worksheets
lrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = sht.Range("A2:A" & lrow)
Set rng2 = sht.Range("F2:F" & lrow)
Set rng3 = sht.Range("E2:E" & lrow)
If Application.CountIf(rng3, "") > 0 Then
MsgBox ("Invalid item number.")
Exit Sub
End If
If Application.CountIf(rng2, "") > 0 Then
MsgBox ("Missing quantity.")
Exit Sub
End If
Next sht
End Sub
The Range.SpecialCells method is Nothing when there are no xlCellTypeBlanks cells available and Nothing does not have a count; not even a count of zero.
You can use the On Error Resume Next or choose a non-destructive method of determining if there are blank cells.
if cbool(application.countblank(rng2)) then
'there are zero-length string and/or blank cells
'do something
end if
The problem with the above is that the worksheet's COUNTBLANK function will count zero-length strings returned by a formula (e.g. "") as blanks when they are not truly blank.
To catch only truly blank cells the following will be True - CBool(rng2.Count - application.Countif(rng2, "<>")). Only truly blank cells will be counted and any non-zero count will be true. This avoids having to crash the environment with On Error Resume Next when there is nothing to find.
This code does what I want per entry in the txtKB textbox:
Dim ws1 As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
Set ws1 = Sheets("Sheet6")
Set wstest = Sheets("Sheet8")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
ws1.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian
but I want to improve it (so that I will not need to manually input the ID in textbox txtKB criteria anymore, and automate everything with just one click of a button) to take an entry in ws2 Column A (like an ID), look it up in ws1 then perform the median extraction, paste the median in wstest then move to the next ID in ws2 until it goes through all IDs in ws2.
Note: ws2 is not yet in the code.
I need to place a loop somewhere I just don't know where.
You could try something like:
Dim ws as worksheet
Dim wb as workbook
set wb = ThisWorkbook
For Each ws in wb.Worksheets
' Do what you want here
next ws
This will loop through all worksheets in the workbook
To work it into your code
Dim wb as workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
set wb = ThisWorkbook
Set wstest = Sheets("Sheet8")
For Each ws in wb.Worksheets ' Loop through all sheets in workbook
if not ws.name = wstest.name then ' Avoid sheet you're copying too (ammend as needed)
With ws
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
End With
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian 'You will need to change your code to paste into different locations I would have assumed, I'll leave that up to you though
End if
Next ws
can anyone help me fix my code? it says "method range of object _worksheet failed" but I can't find what's wrong with it.
I just mashed up a couple of codes to make this before and it worked nicely but now I can't find the error.
what this code does is open the file where it would want to copy the first sheet, put it in the workbook i'm using before the worksheet "Main Page", and it pastes everything to the bottom of the worksheet "BOM-DB" and then it deletes that worksheet and closes the workbook it got it from.
Private Sub CommandButton23_Click()
Application.DisplayAlerts = False
Dim wbk1 As Workbook, wbk2 As Workbook
Dim FileName As String, FileToOpen As String
FileToOpen = Application.GetOpenFilename _
(Title:="Choose Excel File to Import", _
FileFilter:="Excel Files *.xl?? (*.xl??),")
If FileToOpen = "False" Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wbk1 = ActiveWorkbook
Set wbk2 = Workbooks.Open(FileName:=FileToOpen)
wbk2.Sheets.Copy before:=Workbooks(ThisWorkbook.Name).Sheets("Main Page")
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer, k As Integer
Dim ws1LR As Long, ws2LR As Long
Set ws1 = Sheets(1)
Set ws2 = Sheets("BOM-DB")
ws1LR = ws1.Range("AA" & Rows.Count).End(xlUp).Row + 1
ws2LR = ws2.Range("AA" & Rows.Count).End(xlUp).Row
i = 2
k = ws2LR
Do Until i = ws1LR
With ws1
.Range(.Cells(i, 1), .Cells(i, 27)).Copy
End With
With ws2
.Cells(k, 1).Offset(1, 0).PasteSpecial
End With
k = k + 1
i = i + 1
Loop
wbk2.Close
ThisWorkbook.Sheets(1).Delete
End If
Application.DisplayAlerts = True
End Sub
the excel file its always getting from ranges from A to AA.
I made some changes in your code as seen below:
Edit1: Explicitly declare After Argument
Dim wbk1 As Workbook, wbk2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim FileToOpen As String
FileToOpen = Application.GetOpenFilename _
(Title:="Choose Excel File to Import", _
FileFilter:="Excel Files *.xl?? (*.xl??),")
If FileToOpen = "False" Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wbk1 = Thisworkbook: Set ws1 = wbk1.Sheets("BOM-DB")
Set wbk2 = Workbooks.Open(FileName:=FileToOpen)
DoEvents
Set ws2 = wbk2.Sheets(1) '~~> I assume you have only 1 sheet?
With ws2
.Range("A2", .Range("AA" & .Rows.Count).End(xlUp)).Copy
ws1.Range("A" & ws1.Range("A:A").Find("*", ws1.Range("A1") _
, , , , xlPrevious).Row).Offset(1, 0).PasteSpecial xlPasteValues
End With
End If
wbk2.Close False
Is this what you're trying. HTH.
Not sure about the error, but if I'm not mistaken, the PasteSpecial method without any additional arguments is essentially just pasting values only. If that is acceptable, then this will save you a few lines of code and should hopefully avoid the error:
Instead of:
With ws1
.Range(.Cells(i, 1), .Cells(i, 27)).Copy
End With
With ws2
.Cells(k, 1).Offset(1, 0).PasteSpecial
End With
Do this:
With ws1
ws2.Cells(k+1, 1).Resize(1,27).Value = .Range(.Cells(i, 1), .Cells(i, 27)).Value
End With