I have this piece of code: I would like to do a left function on cells G and M in the following code: I am having an issue as when I try:
If left(.Cells(i, "G",4)) <> left(.Cells(i, "M",4)) this does not work.
any advice?
Here is the full code:
Sub SingleTradeMove()
Dim wsTD As Worksheet
Set wsTD = Worksheets("Trade data")
Sheets("Sheet2").Range("A2:AK600").ClearContents
With wsTD
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If .Cells(i, "G") <> .Cells(i, "M") _
Or .Cells(i, "I") <> .Cells(i, "O") _
Or .Cells(i, "L") <> .Cells(i, "R") Then
.Cells(i, "J").EntireRow.Copy _
Destination:=Sheets("Sheet2").Range("A" &
Rows.Count).End(xlUp).Offset(1)
End If
Next i
End With
End Sub
You need to use
If left(.Cells(i, "G"),4) <> left(.Cells(i, "M"),4)
Related
Out of a file with approximately 50.000 rows I want to delete rows which don't have a specific number in column B. I use this code:
Sub DelRows()
Application.ScreenUpdating = False
Worksheets("2016").Activate
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = lastrow To 2 Step -1
If Cells(i, "B").Value <> "1060" And _
Cells(i, "B").Value <> "1061" And _
Cells(i, "B").Value <> "1062" And _
Cells(i, "B").Value <> "1063" And _
Cells(i, "B").Value <> "1064" And _
Cells(i, "B").Value <> "1105" And _
Cells(i, "B").Value <> "11050" And _
Cells(i, "B").Value <> "11051" And _
Cells(i, "B").Value <> "11053" And _
Cells(i, "B").Value <> "11054" And _
Cells(i, "B").Value <> "1160" And _
Cells(i, "B").Value <> "1161" And _
Cells(i, "B").Value <> "1162" And _
Cells(i, "B").Value <> "1163" And _
Cells(i, "B").Value <> "1164" And _
Cells(i, "B").Value <> "1166" And _
Cells(i, "B").Value <> "1168" And _
Cells(i, "B").Value <> "1169" And _
Cells(i, "B").Value <> "8060" And _
Cells(i, "B").Value <> "8061" And _
Cells(i, "B").Value <> "8062" And _
Cells(i, "B").Value <> "8063" And _
Cells(i, "B").Value <> "8064" And _
Cells(i, "B").Value <> "8068" And _
Cells(i, "B").Value <> "8192" Then
Cells(i, "B").EntireRow.Delete
End If
Next i
End Sub
This macro takes a lot of time and it seems to be that there is a maximum of 'and-statements'.
I tried to figure it out with an array or a filter, but it's hard for me as a beginner.
I would like to put the numbers on a separate worksheet as a range e.g.:
A
1 1060
2 1061
3 1062
4 1063
5 1064
…
I've tried to figure it out with section Criteria range on a different sheet* on https://www.rondebruin.nl/win/winfiles/MoreDeleteCode.txt, but I don't fully understand this VBA code.
Can somebody please help me?
Kind regards,
Richard
Let's say the values are as in the code below - rngCheck and rngDelete.
A nested loop can do exactly this job. The outer loop goes through the range, which should be deleted rngDelete and the inner goes through the checking values rngCheck.
If a matching value is found, it is deleted and the inner loop is exited. As far as we are looping through rows and we need to delete some of them, the for loop is with reversed counting:
Option Explicit
Public Sub TestMe()
Dim cnt As Long
Dim rngDelete As Range
Dim rngCheck As Range
Dim rngCell As Range
Set rngCheck = Worksheets(2).Range("A1:A2")
Set rngDelete = Worksheets(1).Range("A1:A20")
For cnt = rngDelete.Rows.Count To 1 Step -1
For Each rngCell In rngCheck
If rngCell = rngDelete.Cells(cnt, 1) Then
rngDelete.Rows(cnt).Delete
Exit For
End If
Next rngCell
Next cnt
End Sub
Here's an array approach which saves on reading from and writing to spreadsheets and so should be a bit quicker. This method includes the cells which do match rather than excluding those which don't. Adjust your range of cells against which you are checking accordingly. I have assumed your data start in A1 of sheet 2016.
Sub DelRows()
Dim v, i As Long, j As Long, vOut(), k As Long, rExcl As Range
Set rExcl = Sheets("Sheet2").Range("A1:A5") 'adjust accordingly
With Worksheets("2016")
v = .Range("A1").CurrentRegion.Value
.Range("A1").CurrentRegion.Offset(1).ClearContents
ReDim vOut(1 To UBound(v, 1), 1 To UBound(v, 2))
For i = LBound(v, 1) To UBound(v, 1)
If IsNumeric(Application.Match(v(i, 2), rExcl, 0)) Then
j = j + 1
For k = LBound(v, 2) To UBound(v, 2)
vOut(j, k) = v(i, k)
Next k
End If
Next i
.Range("A2").Resize(j, UBound(v, 2)) = vOut
End With
End Sub
I am new to VBA and have a small doubt. I was trying to convert certain values from a particular cell from hexadecimal to decimal, I have a small difficulty in that. In that cell there are lot of blank cells. For example the first 5 rows are blank then I have a hex value again 3 blank rows and a hex value. I am not able to loop through due to the blank cell. Please if somebody could help. Below is the code I wrote.
Sub Conversion()
Dim j As Integer
Dim LR As Integer
LR = Range("B" & Rows.Count).End(xlUp).Row
For j = 3 To LR
If Cells(j, 2).value = "" Then Cells(j, 3).value = "#N/A" Else
Cells(j, 3).value = CLng("&H" & Cells(j, 2).value)
Next
End Sub
I am getting Mismatch error with this code
You kinda forgot End If at the end. I have organized your code little bit and add End If and seems it works.
Sub Conversion()
Dim j As Integer
Dim LR As Integer
LR = Range("B" & Rows.Count).End(xlUp).Row
MsgBox Range("B" & Rows.Count).End(xlUp).Row
For j = 3 To LR
If Cells(j, 2).Value = "" Then
Cells(j, 3).Value = "#N/A"
Else
Cells(j, 3).Value = CLng("&H" & Cells(j, 2).Value)
End If
Next
End Sub
CLng is not working, as it is giving error in that as far as i read and understood you can use the below code, YOu can use Format instead of the CLNG command in ur code
Sub Conversion()
Dim j As Integer
Dim LR As Integer
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
If Cells(j, 1).Value = "" Then
Cells(j, 3).Value = "#N/A"
Else
Cells(j, 3).Value = "&H" & Format(Cells(j, 1).Value, "0")
End If
Next
End Sub
Try this:
For j = 3 To LR
If Cells(j, 2).Value = "" Then
Cells(j, 3).Value = "#N/A"
Else
Cells(j, 3).Value = CLng("&H" & Cells(j, 2).Value)
End If
For ignoring errors:
On Error Resume Next
here is one that uses a ternary function
Sub Conversion()
Dim sht As Worksheet
Set sht = ActiveWorkbook.Sheets("Sheet3")
Dim LR As Range
Set LR = sht.Range("B1", sht.Range("B" & sht.Rows.Count).End(xlUp))
Dim cel As Range
For Each cel In LR
cel.Offset(0, 1).Value = IIf(cel.Value = "", "#N/A", CLng("&H" & cel.Value))
Next cel
End Sub
The following script selects a range of data on one sheet and transfers the selection to another sheet.
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.Save
End If
Next i
I would now like to introduce a script which will replace the row of data on the target sheet if the value in column A already exists, but i'm not sure how to achieve this, any help is much appreciated.
Thank you in advance.
Public Function IsIn(li, Val) As Boolean
IsIn = False
Dim c
For Each c In li
If c = Val Then
IsIn = True
Exit Function
End If
Next c
End Function
dim a: a= range(destWB.sheet(whatever)..range("A1"),destWB.Range("A" & destWB.sheet(whatever).Rows.Count).End(xlUp)).value
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
if isin(a, Cells(i, 1) ) then
do whatever you want
else
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.save
End If
End If
Next i
I suggest using a Dictionary-Object which is most likely a Hash-Map. The advantage is that you can use the built in method Dictionary.Exists(Key) to check if the Dictionary already holds the specified value (Key).
Also you should not save the Workbook in every step of the iteration. It would be better (and faster) to only save the workbook after completing the copying of your whole data.
Additionally your If-Tests after copy-paste are not neccessary, because you are already checking for Cells(i,1)<>"" before copying so you don't have to check this again as it does not change.
The following code shows how to get your desired result:
Set dict = CreateObject("Scripting.Dictionary")
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
If dict.Exists(Cells(i,1).Value) Then
'value already exists -> update row number
dict.Item(Cells(i,1).Value)=i
Else
'save value of column A and row number in dictionary
dict.Add Cells(i,1).Value, i
End If
Cells(i, 22).Value = "Yes"
Cells(i, 23).Value = Now
Cells(i, 24).Value = Environ("UserName")
End If
Next i
'finally copy over your data (only unique values)
For Each i In dict.Items
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
Next i
So I have a code I have written the first part of the code is to create a new worksheet with the headings specified. The second part of the code is meant to populate that table with certain information. The problem I am having is getting the correct bits of information to go into the correct columns.
I need the code to search for the value 9.1 in column G in all worksheets within a workbook
if that value is found I need it to copy this to column b in the new sheet along with the following information :
Engine Effect from Column F Same row must be pasted to Column C in the worksheet entitled FHA
Part number is always located in Cell J3 this must be pasted into column D and is always the same
Part Name Is Always located in C2 this must be pasted into column E and is always the same
FM ID from Column B same row must be pasted to Column F in the worksheet entitled FHA
Failure Mode & Cause from Column C Same row must be pasted to column G in FHA
FMCN Value From Column N pasted to Column H In FHA
As It stands the code I have is
Sub createWSheetFHA()
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "FHA"
Cells(1, 2) = "FHA TABLE"
Cells(2, 2) = "FHA Ref"
Cells(2, 3) = "Engine Effect"
Cells(2, 4) = "Part No"
Cells(2, 5) = "Part Name"
Cells(2, 6) = "FM I.D"
Cells(2, 7) = "Failure Mode & Cause"
Cells(2, 8) = "FMCM"
Cells(2, 9) = "PTR"
Cells(2, 10) = "ETR"
Range(Cells(2, 2), Cells(2, 10)).Font.Bold = True
Range(Cells(1, 2), Cells(1, 10)).MergeCells = True
Range(Cells(1, 2), Cells(1, 10)).Font.Bold = True
End Sub
Sub Populate_FHA_Table_2()
Dim wks As Excel.Worksheet, i As Integer, n As Integer
Application.ScreenUpdating = False
Sheets("FHA").Range("A2:" & Columns.Count & ":" & Rows.Count).Delete
i = 1
For Each wks In ActiveWorkbook.Worksheets
If wks.Name <> "FHA" Then
wks.UsedRange.AutoFilter Field:=7, Criteria1:="9.1"
Sheets(i).Range(Sheets(i).Range("G1").Offset(1), Sheets(i).Range("B1").End(xlDown)).Copy _
Sheets("FHA").Range("C" & Rows.Count).End(xlUp)
Sheets(i).Range(Sheets(i).Range("F1").Offset(1), Sheets(i).Range("D1").End(xlDown)).Copy _
Sheets("FHA").Range("d" & Rows.Count).End(xlUp)
Sheets(i).Range(Sheets(i).Range("J1").Offset(1), Sheets(i).Range("E1").End(xlDown)).Copy _
Sheets("FHA").Range("e" & Rows.Count).End(xlUp)
Sheets(i).Range(Sheets(i).Range("C1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _
Sheets("FHA").Range("E" & Rows.Count).End(xlUp)
Sheets(i).Range(Sheets(i).Range("B1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _
Sheets("FHA").Range("F" & Rows.Count).End(xlUp)
Sheets(i).Range(Sheets(i).Range("C1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _
Sheets("FHA").Range("G" & Rows.Count).End(xlUp)
Sheets(i).Range(Sheets(i).Range("N1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _
Sheets("FHA").Range("H" & Rows.Count).End(xlUp)
wks.UsedRange.AutoFilter
End If
i = i + 1
Next
Application.ScreenUpdating = True
End Sub
You have some mismatches in your code (Example using 'for each wk' then accessing via an index 'i'; where they may not necessarily match)
Try something like this...
I have added in some dynamic flow control which isn't strictly needed but if and when your headers change in the future, it may be easier to have it in this form.
Likewise I have tried to add in some error handling as well
Sub Create_FHA_Sheet()
Dim Headers() As String: Headers = _
Split("FHA Ref,Engine Effect,Part No,Part Name,FM I.D,Failure Mode & Cause,FMCM,PTR,ETR", ",")
If Not WorksheetExists("FHA") Then Worksheets.Add().Name = "FHA"
Dim wsFHA As Worksheet: Set wsFHA = Sheets("FHA")
wsFHA.Move after:=Worksheets(Worksheets.Count)
wsFHA.Cells.Clear
Application.ScreenUpdating = False
With wsFHA
For i = 0 To UBound(Headers)
.Cells(2, i + 2) = Headers(i)
.Columns(i + 2).EntireColumn.AutoFit
Next i
.Cells(1, 2) = "FHA TABLE"
.Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).MergeCells = True
.Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 2), .Cells(2, UBound(Headers) + 2)).Font.Bold = True
End With
Dim RowCounter As Long: RowCounter = 3
Dim SearchTarget As String: SearchTarget = "9.1"
Dim SourceCell As Range, FirstAdr As String
If Worksheets.Count > 1 Then
For i = 1 To Worksheets.Count - 1
With Sheets(i)
Set SourceCell = .Columns(7).Find(SearchTarget, LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
FirstAdr = SourceCell.Address
Do
wsFHA.Cells(RowCounter, 3).Value = .Cells(SourceCell.Row, 6).Value
wsFHA.Cells(RowCounter, 4).Value = .Cells(3, 10).Value
wsFHA.Cells(RowCounter, 5).Value = .Cells(2, 3).Value
wsFHA.Cells(RowCounter, 6).Value = .Cells(SourceCell.Row, 2).Value
wsFHA.Cells(RowCounter, 7).Value = .Cells(SourceCell.Row, 3).Value
wsFHA.Cells(RowCounter, 8).Value = .Cells(SourceCell.Row, 14).Value
Set SourceCell = .Columns(7).FindNext(SourceCell)
RowCounter = RowCounter + 1
Loop While Not SourceCell Is Nothing And SourceCell.Address <> FirstAdr
End If
End With
Next i
End If
Application.ScreenUpdating = True
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
I have User form where I have command button and input text box.
I want to copy specified range from one worksheet, then name and paste in another sheet.
My code looks like this, but it is not working.
Private Sub CommandButton1_Click()
Dim i, LastRow
Dim ws As Worksheet
Dim k As Integer
Set ws = Worksheets("Vali")
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To LastRow 'find fulfiled rows
If Sheets("Sheet1").Cells(i, "D").Value = 1 Then
Sheets("Sheet1").Range(Cells(i, "B"), Cells(i, "D")).Copy Destination:=Sheets("Vali").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
Dim i As Integer
'Next we use a looping process 'We start the loop from row 2 because our worksheet has headers in row 1
For k = 2 To 100
'Now we define a condition that only if there is data under the headers ItemID, Description,
If Cells(k, "A").Value <> "" And Cells(k, "B").Value <> "" And Cells(k, "C").Value <> "" And Cells(k, "D").Value <> "" And Cells(k, "E").Value = "" Then
Cells(k, "D").Value = Me.txtname.Value
End If
Next
Range("E:E").EntireColumn.AutoFit
Range("B4:D21").ClearContents 'clear content on previos sheet, from where we made copy
ActiveWorkbook.Save
ValiFinish.Hide
End Sub
Not sure what you were trying to do with your test on you second loop, because there was no sheet reference, so I choose, let me know if it wasn't that
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim LastRow As Double
Dim ws As Worksheet
Dim Wv As Worksheet
Dim k As Integer
Dim i As Integer
Dim Ti()
ReDim Ti(0)
Dim StartPaste As Double
Dim EndPaste As Double
Dim PastedRange As String
Set ws = Worksheets("Sheet1")
Set Wv = Worksheets("Vali")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
StartPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
For i = 2 To LastRow
If ws.Cells(i, "D").Value = 1 Then
ws.Range(ws.Cells(i, "A"), ws.Cells(i, "D")).Copy _
Destination:=Wv.Range("A" & Rows.Count).End(xlUp).Offset(1)
Ti(UBound(Ti)) = i
ReDim Preserve Ti(UBound(Ti) + i)
EndPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
'2 options because i'm not sur where you want to add the text :
'First one (write on Vali, I think that's what you are looking to do) :
If Wv.Cells(EndPaste, "A").Value <> "" And Wv.Cells(EndPaste, "B").Value <> "" And Wv.Cells(EndPaste, "C").Value <> "" _
And Wv.Cells(EndPaste, "D").Value <> "" And Wv.Cells(EndPaste, "E").Value = "" Then
Wv.Cells(Wv.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'Second one (write on Sheet1) :
If ws.Cells(i, "A").Value <> "" And ws.Cells(i, "B").Value <> "" And ws.Cells(i, "C").Value <> "" _
And ws.Cells(i, "D").Value <> "" And ws.Cells(i, "E").Value = "" Then
ws.Cells(ws.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'end of options
End If
Next i
PastedRange = "" & Wv.Name & "!R" & StartPaste & "C1:R" & EndPaste & "C3"
ActiveWorkbook.Names.Add Name:=ValiFinish.TxTNaMe.Value, RefersToR1C1:=PastedRange
'clear content on previous sheet, from where we made copy
For i = LBound(Ti) To UBound(Ti) - 1
ws.Range("$B$" & Ti(i) & ":$D$" & Ti(i)).ClearContents
Next i
Wv.Range("E:E").EntireColumn.AutoFit
Set ws = Nothing
Set Wv = Nothing
ActiveWorkbook.Save
ValiFinish.Hide
Application.ScreenUpdating = True
End Sub