i want to if my cell (b5,c5) is blank than cell (f5,g5,h5) also make blank also ,cell (b6,c6) is blank than cell (f6,g6,h6) ,cell (b7,c7) is blank than cell (f7,g7,h7) ,cell (b8,c8) is blank than cell (f8,g8,h8) ,cell (b9,c9) is blank than cell (f9,g9,h9) , but same in i want this code 200 time help me make a small code.thanks in advance.
Sub BLANK()
If Range("B5,C5") = "" Then
Range("F5,G5,H5") = ""
If Range("B6,C6") = "" Then
Range("F6,G6,H6") = ""
If Range("B7,C7") = "" Then
Range("F7,G7,H7") = ""
' same code in cell("b5:b200") make small code please
end if
end sub
I will recomend you to use something like this. Where ranges and sheet is properly declared, and also all variables are properly declared with using option explicit to prevent you from multiple issues
Sub makeBlank()
Dim mySheet As Worksheet
Set mySheet = Sheets("devSheet")
Dim rowCounter As Long
With mySheet
For rowCounter = 5 To 200
If .Range("B" & rowCounter & ",C" & rowCounter).Value = "" Then
.Range("F" & rowCounter & ",G" & rowCounter & ",H" & rowCounter).Value = ""
End If
Next rowCounter
End With
End Sub
The below will loop over 200 times and produce the results you require
For x = 5 to 200
If Range(Cells(x,2), Cells(x,3)).Value = "" Then
Range(Cells(x,6), Cells(x,8)).Value = ""
End if
Next x
Related
I am trying to copy text values only from column H and move them to E. I want to automate it so that everytime a text value comes to H from sheet1, it directly goes to E instead of H. Leaving H empty in that cell.
Sheets("102Tk").Select
Dim row As Long
For row = 17 To 1000
' Check if "textvalue" appears in the value anywhere.
If WorksheetFunction.IsText(Range("H" & i)) Then
' Copy the value and then blank the source.
Range("E" & i).value = Range("H" & i).value
Range("H" & i).value = ""
End If
Next
End Sub
Should i be row?
Option Explicit
Sub n()
Sheets("102Tk").Select
Dim row As Long
For row = 17 To 1000
' Check if "save" appears in the value anywhere.
If Not IsNumeric(Range("H" & row)) Then
' Copy the value and then blank the source.
Range("E" & row).Value = Range("H" & row).Value
Range("H" & row).Value = ""
End If
Next
End Sub
Which avoiding using row as a variable name and a few other tidies could be:
Option Explicit
Public Sub SetValues()
Dim currentRow As Long
With ThisWorkbook.Worksheets("102Tk") 'taking note of the comments and using worksheet collection to avoid Chart sheets
For currentRow = 17 To 1000
' Check if "save" appears in the value anywhere.
If Not IsNumeric(.Range("H" & currentRow)) Then
' Copy the value and then blank the source.
.Range("E" & currentRow) = .Range("H" & currentRow)
.Range("H" & currentRow) = vbNullString
End If
Next currentRow
End With
End Sub
I'm experiencing some issues getting the provided VBA code working and would appreciate any assistance.
I have two Workbooks (1) is a monthly report I receive that has multiple worksheets, Worksheet "host_scan_data" contains the source of the information I will need to work with. The other Workbook (2) is where I will store all consolidated date month over month.
How I'm trying to accomplish this task:
1. launch workbook #2
2. click a button that has the following VBA code assigned to (see below)
3. browse and select my monthly report (workbook #1)
4. specify the worksheet tab in workbook #2 where i'd like to store this consolidate information
5. prompt user to validate worksheet tab where data will be stored
Based on the responses above the macro will then analyze Column K within the "host_scan_data" Sheet of the Workbook (1), and I would like for it to remove all rows where Column k contains a "0" (note the only values i'm concerned about are 4,3,2,1). Once that action is complete i'd like for the macro to copy the consolidated list of entry's over to the location specified in step #4 above.
I've tried this with a few variations of code and other solutions appear to work fine when the "host_scan_data" Sheet contains <4,000 rows however once I exceed that number (give or take) excel becomes unresponsive. Ideally this solution will need to handle approx 150,000+ rows.
Here is the code i'm currently using, when i execute it errors out at ".Sort .Columns(cl + 1), Header:=xlYes":
The Code I Have so far:
Sub Import()
Dim strAnswer
Dim itAnswer As String
Dim OpenFileName As String
Dim wb As Workbook
Dim db As Workbook
Dim Avals As Variant, X As Variant
Dim i As Long, LR As Long
'Optimize Code
Call OptimizeCode_Begin
'Select and Open workbook
OpenFileName = Application.GetOpenFilename("*.xlsx,")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
Set db = ThisWorkbook
'Provide Sheet Input
strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")
If strAnswer = "" Then
MsgBox "You must enter a valid name. Exiting now..."
wb.Close
Exit Sub
Else
Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
If Response = vbNo Then
MsgBox "Got it, you made a mistake. Exiting now..."
wb.Close
Exit Sub
Else: MsgBox "Importing Now!"
End If
End If
wb.Sheets("host_scan_data").Activate
Dim rs, cl, Q()
Dim arr1, j, C, s As Long
Dim t As String: t = "4"
Dim u As String: u = "3"
Dim v As String: v = "2"
Dim w As String: w = "1"
If Cells(1) = "" Then Cells(1) = Chr(2)
'Application.Calculation = xlManual
rs = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByRows, xlPrevious).Row
cl = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByColumns, xlPrevious).Column
ReDim Q(1 To rs, 1 To 1)
arr1 = wb.Sheets("host_scan_data").Cells(1, "k").Resize(rs)
For j = 1 To rs
C = arr1(j, 1)
If (C <> t) * (C <> u) * (C <> v) * (C <> w) Then Q(j, 1) = 1: s = s + 1
Next j
If s > 0 Then
With Cells(1).Resize(rs, cl + 1)
.Columns(cl + 1) = Q
.Sort .Columns(cl + 1), Header:=xlYes
.Cells(cl + 1).Resize(s).EntireRow.Delete
End With
End If
countNum = (Application.CountA(Range("B:B"))) - 1
MsgBox (countNum & " Rows being imported now!")
countNum = countNum + 2
db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
MsgBox ("Done")
'Close nessus file
wb.Close SaveChanges:=False
'Else
'MsgBox "You must enter 1 or 2 only. Exiting now..."
'wb.Close
'Exit Sub
'End If
Sheets(strAnswer).Select
'Optimize Code
Call OptimizeCode_End
End Sub
So here is what may be happening.
If the row you are deleting has data used, in a formula somewhere else, that formula is going to recalculate on every iteration of the row delete.
I had this problem with a data set which has many Vlookup functions pulling data.
here is what I did and it take a few seconds rather than 30min
Sub removeLines()
Dim i As Long
Dim celltxt As String
Dim EOF As Boolean
Dim rangesize As Long
EOF = False
i = 1
'My data has "End of File" at the end so I check for that
' Though it would be better to used usedRange
While Not (EOF)
celltxt = ActiveSheet.Cells(i, 1).Text
If InStr(1, celltxt, "end", VbCompareMethod.vbTextCompare) > 0 Then
EOF = True 'if we reach the "end Of file" then exit
' so I clear a cell that has no influence on any functions thus
' it executes quickly
ElseIf InStr(1, celltxt, "J") <> 1 Then
Cells(i, 1).Clear
End If
i = i + 1
Wend
' once all the rows to be deleted are marked with the cleared cell
' I use the specialCells to select and delete all the rows at once
' so that the dependent formula are only recalculated once
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
hope this helps and that it is read able
I tried a little different approach by using AutoFilter and i'm seeing a high success rate on my larger lists however there still is one issue. With the code below i was able to parse through 67k+ rows and filter/delete any row contains a "0" in my column K (this takes approx 276 seconds to complete), after the code filters and deletes the rows with zeros it clears any existing filters then is to copy the remaining data into my Workbook #2 (this is approx 7k rows) however it is consistently only copying 17 rows of data into my workbook #2, it just seems to stops and i have no idea why. Also, while 4.5 mins to complete the consolidation could be acceptable does anyone have any ideas on how to speed this up?
Sub Import()
Dim strAnswer
Dim itAnswer As String
Dim OpenFileName As String
Dim wb As Workbook
Dim db As Workbook
Dim Avals As Variant, X As Variant
Dim i As Long
Dim FileLastRow As Long
Dim t As Single
Dim SevRng As Range
t = Timer
'Optimize Code
Call OptimizeCode_Begin
'Select and Open workbook
OpenFileName = Application.GetOpenFilename("*.xlsx,")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
Set db = ThisWorkbook
'Provide Sheet Input
strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")
If strAnswer = "" Then
MsgBox "You must enter a valid name. Exiting now..."
wb.Close
Exit Sub
Else
Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
If Response = vbNo Then
MsgBox "Got it, you made a mistake. Exiting now..."
wb.Close
Exit Sub
Else: MsgBox "Importing Now!"
End If
End If
FileLastRow = wb.Sheets("host_scan_data").Range("K" & Rows.Count).End(xlUp).Row
Set SevRng = wb.Sheets("host_scan_data").Range("K2:K" & FileLastRow)
Application.DisplayAlerts = False
With SevRng
.AutoFilter Field:=11, Criteria1:="0"
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Delete
.Cells.AutoFilter
End With
Application.DisplayAlerts = True
MsgBox "Consolidated in " & Timer - t & " seconds."
countNum = (Application.CountA(Range("B:B"))) - 1
MsgBox (countNum & " Rows being imported now!")
countNum = countNum + 2
db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
MsgBox ("Done")
'Close nessus file
wb.Close SaveChanges:=False
Sheets(strAnswer).Select
'Optimize Code
Call OptimizeCode_End
End Sub
Does your
"MsgBox (countNum & " Rows being imported now!")"
return the correct number of rows?
CountA will stop counting at the first empty cell.
Try instread:
countNum = ActiveSheet.UsedRange.Rows.Count
The purpose of this macro is copy one cell value (from a long list) to another cell located in a different sheet.
here's my code:
Sub journalben()
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
Set Rng = Range("G2:G1048576")
For Each cell In Rng
'test if cell is empty
If cell.Value <> "" Then
finaljnl.Range("L4").Value = rawben.Range("G5").Value
finaljnl.Range("K4").Value = rawben.Range("L5").Value
End If
Next
End Sub
With the help of the image, I will explain what I'm trying to achieve:
From Sheet1 ("BEN") there's a list sitting in columns G and L.
I will copy the cell G5 from Sheet1 and paste it in Sheet2 ("JNL_BEN") Range K4.
Next is I will copy the cell L5 from Sheet1 and paste it in Sheet2 ("JNL_BEN") Range L4.
Copy the next in line and do the same process just like No.2 and 3 but this time, it will adjust 1 row below.
Copy the whole list. That means up to the bottom. The list is dynamic, sometimes it will go for 5,000 rows.
For some reasons, copying the entire column is not an option to this macro due to requirement that cells from sheet1 MUST be pasted or placed in Sheet2 from left to right (or horizontally).
I hope you could spare some time to help me. My code didn't work, I guess the implementation of FOR EACH is not correct. I'm not sure if FOR EACH is the best code to use.
I appreciate anyone's help on this. Thank you very much! May the force be with you.
Try this:
Sub journalben()
Dim i As Long, lastRow As Long
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
lastRow = rawben.Cells(Rows.Count, "G").End(xlUp).Row
For i = 5 To lastRow
'test if cell is empty
If rawben.Range("G" & i).Value <> "" Then
finaljnl.Range("K" & i - 1).Value = rawben.Range("G" & i).Value
finaljnl.Range("L" & i - 1).Value = rawben.Range("L" & i).Value
End If
Next i
End Sub
I am starting FOR from 5 as the data in your image starts from cell G5 (not considering the header).
It'll be easier to use a numeric variable for this :
Sub journalben()
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
Set Rng = rawben.Range("G4:G1048576")
For i = Rng.Cells(1,1).Row to Rng.Cells(1,1).End(xlDown).Row
'test if cell is empty
If rawben.Range("G" & i).Value <> vbNullString Then
finaljnl.Range("L" & i - 1).Value = rawben.Range("G" & i).Value
finaljnl.Range("K" & i - 1).Value = rawben.Range("L" & i).Value
End If
Next i
End Sub
You should use a simple for loop. It is easier to work with.
Also, to have it dynamic and to go to the last cell in the range, use the SpecialCells method.
And your range needs to be set correctly from row 5.
Here is the code:
Sub journalben()
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
Set Rng = Range("G5:G1048576")
For i = Rng.Cells(1,1).Row to Rng.SpecialCells(xlCellTypeLastCell).Row
If rawben.Range("G" & i).Value <> vbNullString Then
finaljnl.Range("L" & CStr(i - 1)).Value = rawben.Range("G" & CStr(i)).Value
finaljnl.Range("K" & CStr(i - 1)).Value = rawben.Range("L" & CStr(i)).Value
End If
Next i
End Sub
I need your help please, I have 4 columns in an excel sheet and I need to compare them 2 by 2 i will explain to you :
In column A i have users(user1,user2,user3 ...)
In column B i have functionalities ( fonc1, fonc2, fonc3.....)
In column C i have users(user1,user2,user3 ...)
In column D i have functionalities ( fonc1, fonc2, fonc3.....)
The columns C and D are a new version of columns A and B in the columns C and D the users may change order or change functionalities .
When i execute my code i put the result in other new columns:
column F where i have the users
column G where i put the Deleted_functionalities
column H where i put the New_functionalities
The first problem is that the code doesn't get the users it get only the new and deleted functionalities. The second problem is that when the column A is more than column C where the users are stocked the code doesn't work. Can you please help me to find a solution? Thank you in advance .
Here is my code and the file I am working on :
Private Sub CommandButton2_Click()
Dim rngCell As Range
For Each rngCell In Range("B2:B2000")
If WorksheetFunction.CountIf(Range("D2:D2000"), rngCell) = 0 Then
Range("G" & Rows.Count).End(xlUp).Offset(1) = rngCell
End If
Next
For Each rngCell In Range("D2:D2000")
If WorksheetFunction.CountIf(Range("B2:B2000"), rngCell) = 0 Then
Range("H" & Rows.Count).End(xlUp).Offset(1) = rngCell
End If
Next
End Sub
and this is the excel file
http://www.cjoint.com/c/FCxnwjp22rv
try this
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim cell As Range, funcCell As Range
Dim oldUserRng As Range, newUserRng As Range, reportRng As Range
Dim iReport As Long
Dim oldFunc As String, newFunc As String
Set ws = ThisWorkbook.Worksheets("users") '<== adapt it to your needs
With ws
Set oldUserRng = .Columns(1).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeConstants, xlTextValues)
Set newUserRng = .Columns(3).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeConstants, xlTextValues)
Set reportRng = .Range("F1:I1") '<== added one report column to account for unchanged functions
End With
reportRng.Value = Array("user", "deleted", "new", "same")
iReport = 1
For Each cell In oldUserRng
With cell
oldFunc = .Offset(, 1).Value
Set funcCell = FindAndOffset(newUserRng, .Value, 1)
If funcCell Is Nothing Then
reportRng.Offset(iReport) = Array(.Value, "", "", oldFunc)
Else
newFunc = funcCell.Value
If newFunc = oldFunc Then
reportRng.Offset(iReport) = Array(.Value, "", "", newFunc)
Else
reportRng.Offset(iReport) = Array(.Value, oldFunc, newFunc, "")
End If
End If
iReport = iReport + 1
End With
Next cell
For Each cell In newUserRng
With cell
Set funcCell = FindAndOffset(oldUserRng, .Value, 1)
If funcCell Is Nothing Then
reportRng.Offset(iReport) = Array(.Value, "", .Offset(, 1).Value, "")
iReport = iReport + 1
End If
End With
Next cell
End Sub
Not so sure it does what you need.
you'd better provide screenshots of "before" and "after" scenarios.
BTW, is it safe to assume that both old and new user columns cannot hold duplicates (i.e.: two or more "userX" in column A and/or column C?)
But it does speed up thing considerably since it iterates only through non empty cells.
I hope I get what you want to achieve. Does the following solve your problem?
Private Sub CommandButton2_Click()
Dim rngCell As Range
For Each rngCell In Range("A2:A20000")
If WorksheetFunction.CountIf(Range("C2:C20000"), rngCell) > 0 Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 1) = rngCell.Offset(0, 1).Value
Range("F" & Rows.Count).End(xlUp).Offset(0, 2) = Application.WorksheetFunction.VLookup(rngCell.Value, Range("C2:D20000"), 2, 0)
ElseIf (rngCell <> "") Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 1) = rngCell.Offset(0, 1).Value
End If
Next
For Each rngCell In Range("C2:C20000")
If (WorksheetFunction.CountIf(Range("A2:A20000"), rngCell) = 0 And rngCell <> "") Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 2) = rngCell.Offset(0, 1).Value
End If
Next
End Sub
A user is only included in column F when he appears both in columns A and C.In case you want to include every user that is either in column A or C the code has to be altered.
This program aims to compare two named ranges in two sheets. If the cells values are found in both sheets it highlights cells in green otherwise in red.
In my code below, I get a logical error.
I compare the results in the two sheets manually but I get totally different results.
Public Sub FindBtn_Click()
range1Name = namedRange1TxtBox
range2Name = namedRange2TxtBox
sheet1Name = Sheet1txt
sheet2Name = Sheet2txt
Dim range1No(), range2No() As Variant
range1No() = Range(range1Name)
range2No() = Range(range2Name)
Dim i, j As Integer
Dim cell As Variant 'Range
For i = LBound(range1No()) To UBound(range1No())
For j = LBound(range2No()) To UBound(range2No())
Set cell = Worksheets(sheet1Name).Range(range1Name).Find(what:=Worksheets(sheet2Name).Range(range2Name).Cells(i, 1).Value, lookat:=xlWhole)
If Not cell Is Nothing Then ' if jde cell value is found in tops then green jde cell
Worksheets(sheet1Name).Range(range1Name).Cells(i, 1).Interior.ColorIndex = 4
Else
Worksheets(sheet1Name).Range(range1Name).Cells(i, 1).Interior.ColorIndex = 3
End If
Application.StatusBar = "Progress: " & i & " of " & UBound(range1No()) '& Format(i / 9331, "%")
Next j
Next i
Without spending a while on in, I'm not too sure what's actually wrong with your code. But how about doing it this way (I substituted strings in the variables so I could make it work locally).
Public Sub FindBtn_Click()
range1Name = "firstrange"
range2Name = "secondrange"
sheet1Name = "Sheet1"
sheet2Name = "Sheet2"
Dim range1cell As Range
Dim range2cell As Range
For Each range1cell In Range(range1Name)
range1cell.Interior.ColorIndex = 3
For Each range2cell In Range(range2Name)
If range1cell.Value = range2cell.Value Then
range1cell.Interior.ColorIndex = 4
Exit For
End If
Next range2cell
Next range1cell
End Sub
On looking closer, I notice that while you're looping through values of j you don't seem to refer to j anywhere else.
the following code solved my problem basicly I don't know how to use the find function properly. below a code that does the job :)
Thanks :)
Dim cell1 As Range, cell2 As Range
Dim add1 As Variant
With Worksheets("JDE").Range("JS_No")
For Each cell2 In Worksheets("TOPS").Range("TechID")
Set cell1 = .Find(cell2, LookIn:=xlValues)
If Not cell1 Is Nothing Then
add1 = cell1.Address
Do
cell1.Interior.ColorIndex = 4
cell2.Interior.ColorIndex = 4
Application.StatusBar = "Processing: " & add1
Loop While Not cell1 Is Nothing And cell1.Address <> add1
End If
Next cell2
End With