I am trying to figure out how to get my zero values to copy and paste to the same row. If I have a range of them from G4:G8, they paste to C1:C4, how can I get them to go directly over with out starting at the beginning of C.
Sub CopyZeroData()
Dim sh1 As Worksheet, x As Long, y As Long, N As Long, rng As Range
Set sh1 = Sheets("Ecars")
N = sh1.Cells(Rows.Count, "G").End(xlUp).Row
y = 1
For x = 1 To N
Set rng = sh1.Cells(x, "G")
If rng.Value = 0# Then
rng.Copy sh1.Cells(y, "C")
y = y + 1
End If
Next x
End Sub
Thanks!
You can use offset as well in your code. Your question, it looks like you are looping through column G, if it equals zero, you want column c to equal zero.
Sub If_Zero()
Dim sh1 As Worksheet, N As Long, rng As Range, c As Range
Set sh1 = Sheets("Ecars")
With sh1
N = .Cells(.Rows.Count, "G").End(xlUp).Row
Set rng = .Range("G1:G" & N)
End With
For Each c In rng.Cells
If c = 0 Then c.Offset(0, -4) = c
Next c
End Sub
Related
I have a column "F" in workbook1 containing some values (obtained after using some excel formulas to extract and concatenate from other columns) like
blah-rd1
blah-rd5
blah-rd6
blah-rd48do I want to do this
blah-rd100
etc
I have another column "D" in workbook2 containing values like
rndm-blah-rd1_sgjgs
hjdf-blah-rd5_cnnv
sdfhjdf-blah-rd100_cfdnnv
ect
Basically "Blah-rdxx" is always present alongwith other strings in D column of workbook2
Now, what I want to do is -
If value in D column of workbook2 contains value of F column of workbook1 Then
copy corresponding value of S column of workbook2 in H column of workbook1 (5th column)
This is where I have reached so far but it doesnt copy anything probably coz there is some problem and the outer loop is not iterating, I tried following solution Nested For Next Loops: Outer loop not iterating and added n counter but still outer loop doesn't iterate -
Sub findandcopy()
Dim r As Range
Dim f As Range
Dim i As Long
Dim j As Long
Dim w1 As Worksheet
Dim w2 As Worksheet
Dim n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
w2.Cells(i, 2).Copy (w2.Cells(j, 5))
Exit For
n = n + 1
End If
Next j
Next i
End Sub
Try this
Option Explicit
Public Sub FindAndCopy()
Const F = "F"
Const D = "D"
Const H = 2
Const S = 15
Dim ws1 As Worksheet: Set ws1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Workbooks("Book2.xlsm").Worksheets("Sheet1")
Dim lr1 As Long: lr1 = ws1.Cells(ws1.Rows.Count, F).End(xlUp).Row
Dim lr2 As Long: lr2 = ws2.Cells(ws2.Rows.Count, D).End(xlUp).Row
Dim itm1 As Range, itm2 As Range
Application.ScreenUpdating = False
For Each itm2 In ws2.Range(ws2.Cells(1, D), ws2.Cells(lr2, D)) 'Book2
For Each itm1 In ws1.Range(ws1.Cells(1, F), ws1.Cells(lr1, F)) 'Book1
If Not IsError(itm1) And Not IsError(itm2) Then
If InStr(1, itm2.Value2, itm1.Value2) > 0 Then
itm1.Offset(, H).Formula = itm2.Offset(, S).Formula 'Book1.H = Book2.S
Exit For
End If
End If
Next
Next
Application.ScreenUpdating = True
End Sub
The original code, with explanations of functional issues:
Sub findandcopy()
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row 'for each used cell in w2.colA
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n 'for each used cell in w1.colA
'Find the text from w1.colC (current w1 row), within cell in w2.colA (current w2 row)
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
'If found then copy cell in w2.colB into cell in w2.colE (current w2 row)
w2.Cells(i, 2).Copy (w2.Cells(i, 5))
Exit For 'this exits the inner For loop
n = n + 1 'this would jump over the next cell(s) in w1, but never executes
End If
Next j
Next i
End Sub
The missing indentation makes it hard to follow
There are unused variables (r, f), and w1 / w2 names can mean Workbook, or Worksheet
"Option Explicit" should be used at the top of every module
The code doesn't handle cells with errors
#N/A, #VALUE!, #REF!, #DIV/0!, #NUM!, #NAME?, or #NULL!
If you'd like a more detailed review of the code, once it's fixed you can post it on Code Review
I am trying to split data into multiple worksheets but when I run my codes, it seems like it has lost its format. The list contains parent codes of the products I am based on splitting.
Product code has 0000-00-00 format and parent code is the first 4 digits, 0000. i.e. 0008-99-99 as product code and 0008 as parent code.
So in my result page, I m getting 8 as result not 0008, and that is why I can't get any product details in them. I tried to use left function and it is still giving me 8 not 0008 for instance. I need help with Sheets(n).Range("A1") = ws3.Cells(i, 1).Text this line of code. When I run my codes, no error just not populating results.
Option Explicit
Sub monthly()
Dim y1 As Workbook
Dim ws1, ws2, ws3 As Worksheet
Dim LR1, LR2, LR3, last As Long
Dim o, r, p As Long
Set y1 = Workbooks("Monthly Template.xlsm")
Set ws2 = y1.Sheets("Products")
Set ws3 = y1.Sheets("List")
LR2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row
ws3.Activate
With ws3
Range("A1:A32").Sort key1:=Range("A1"), Order1:=xlAscending
End With
LR1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For o = 3 To LR1
ws2.Cells(o, 29).FormulaR1C1 = "=LEFT(RC[-21],4)"
Next o
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As String
With Sheets("List")
j = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Sheets("Products")
l = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To j
n = Sheets("List").Cells(i, 1).Text
Sheets.Add(After:=Sheets(Sheets.Count)).Name = n
Sheets(n).Range("A1") = ws3.Cells(i, 1).Text
For k = 3 To l
With Sheets(n)
If Sheets(n).Cells(1, 1).Value = Sheets("Products").Cells(k, 29).Value Then
m = .Cells(.Rows.Count, 1).End(xlUp).Row
.Rows(m + 1).Value = Sheets("Products").Rows(k).Value
End If
End With
Next k
Next i
End Sub
The idea behind this is to use vba vlookup on column G:AI from sheet11-13 to sheet1. Header ends at row 3 across all worksheets.
I have written the codes as below. The code stops at the ws1.Cells(r, c).Value = Application.WorksheetFunction.VLookup(ws1.Cells(r, 1).Value, ws2.Range("A1:AI500"), colnum, False) showing subset out of range and sometimes even
Run-time error '1004': Unable to get the VLookup property of the WorksheetFunction class.
Please advice on the way forward.
I Would like to send out files for better clarification but can't seem to find the attach function. Thank you !
Sub green_update()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet13")
Dim bil As String
Dim lastrow As Long
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
'mysheets = "sheet11:sheet12:sheet13"
'i would like to allow vlookup to search through all sheet 11-13
For for_col = 1 To ws2.Cells("4", Columns.Count).End(xlToLeft).column
lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).row
For i = 1 To lastrow - 3
ws1.Cells(r, c).Value = Application.WorksheetFunction.VLookup(ws1.Cells(r, 1).Value, ws2.Range("A1:AI500"), colnum, False)
r = r + 1
Next
r = 4
colnum = colnum + 1
c = c + 1
Next
End Sub
As you have totally changed what you were asking.. I am posting another answer to make it clear.
Still your request is not totally clear so that some inputs may refer to wrong destinations but you can change those ones easily.
If you don't understand any part feel free to ask it again.
Option Explicit
Sub green_update()
Application.ScreenUpdating = False
Dim zaman As Double
zaman = Timer
Dim wb As Workbook, ws1 As Worksheet, wsNames as Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Dim colNo As Long, OthARowNo As Long, sh1ARowNo As Long
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
For Each wsNames In Sheets(Array("sheet11", "sheet12", "sheet13"))
colNo = wsNames.Cells("4", Columns.Count).End(xlToLeft).column
'Column numbers are 35 but you are working between G:AI which is 29 columns!
OthARowNo = wsNames.Cells(Rows.Count, "A").End(xlUp).row
sh1ARowNo = ws1.Cells(Rows.Count, "A").End(xlUp).row
For for_col = 7 To colNo 'colNo Is 35 Green columns start at 7th column, totally 29 loop, till 35th one.
For i = 1 To sh1ARowNo 'This should run until sh1's row number
ws1.Cells(r, c).Value = Application.VLookup(ws1.Cells(r, 1).Value, wsNames.Range("A1:AI" & OthARowNo), colnum, False)
If IsError(ws1.Cells(r, c).Value) Then
ws1.Cells(r, c).Value = ""
End If
r = r + 1
Next i
r = 4
colnum = colnum + 1
c = c + 1
Next for_col
colnum = 7
c = c + 6 'There are 6 columns between AI:AP and BR:BY
Next wsNames
Application.ScreenUpdating = True
MsgBox Format(Timer - zaman, "00.00") & "secs"
End Sub
I explained my answer within the code, but to summarize your problems:
1- You don't define your variables, especially worksheets. Never Assume your worksheet and always define and set references to Workbooks and Worksheets
2- You are limiting your For loops with the Row number of A column and Column number of 3rd row, but what if they are empty or not compatible with your lookup rounds? Then you may get error or wrong results. Define them carefully.
Option Explicit
Sub green_update()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1") 'Change this Sheet1 name with your current Worksheet name
Set ws2 = wb.Sheets("mysheets")
Dim bil As String 'I don't know where do you use that variable.
Dim lastrow As Long 'Prefer to work with Long instead of Integer
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
For for_col = 1 To ws2.Cells("4", Columns.Count).End(xlToLeft).Column
'This is important! Here in this case are you sure you, _
'you would like to define how many times your For loop will run based on 3rd row?
lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
'This is also important! Are you sure you would like to run your For loop_
'based on the row number of A column? I think you should define it -3 _
'because you start your lookup from D4 (so first 3 one Is not necessary)
For i = 1 To lastrow - 3
ws1.Cells(r, c).Value = WorksheetFunction.VLookup(ws1.Cells(r, 4).Value, ws2.Range("A1:AI500"), colnum, False)
r = r + 1
Next
r = 4
colnum = colnum + 1
c = c + 1
Next
End Sub
In the following code, I'm having the hardest time identifying a specific cell in the variable range "rngCell". In the "If" statement, I would like to copy a specific cell in that column or row that the rngCell (the active cell is at) instead of the value of rngCell. I've tried using offset but have been failing. Example: If rngCell is at e42, I may need a value from e2 or a42.
Thank you.
Dim rngCell As Range
Dim lngLstRow As Long
Dim ws As Worksheet, resultsWS As Worksheet
lngLstRow = ws.UsedRange.Rows.Count
Worksheets("FileShares").Select
j = 4
p = 1
q = 4
g = 6
Dim k&
For k = 9 To 50
With ws
For Each rngCell In .Range(.Cells(8, k), .Cells(lngLstRow, k))
For i = LBound(maxKeywords) To UBound(maxKeywords)
If rngCell.Value = maxKeywords(i) And rngCell.Interior.ColorIndex = 3 Then
resultsWS.Cells(g, 2).Offset(j + p, 0) = rngCell.Value
g = g + 1
j = q + p - 5 'Used to start at row 8 and every row after
End If
Next i
Next rngCell
End With
Next k
If rngCell is E42 then:
rngCell.EntireRow.Cells(1) '>>A42
rngCell.EntireColumn.Cells(2) '>>E2
or
ws.Cells(rngCell.Row, 1) '>>A42
ws.Cells(2, rngCell.Column) '>>E2
How do i loop through one million rows in vba to find the instr numbers then trying to copy it to different sheet. I have a two different worksheet, one of them holding one million strings and the one 150. And im looping through to finding instr then pasting into another sheets.My code is working slow also how do i make it faster.
Sub zym()
Dim x As Long, lastrow As Long, lastrowx As Long, i As Long, ii As Long
Dim ws As Worksheet, wb As Workbook, ws2 As Worksheet, wb2 As Workbook
Dim b As String, ws3 As Worksheet, ym As Long, lastrowy As Long, iii As Long
Dim j As Integer
Dim data As Variant
Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
j = 1
Dim sheet1array As Variant, sheet2array As Variant
T1 = GetTickCount
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
lastrowx = ws2.Range("A" & Rows.Count).End(xlUp).Row
ReDim sheet1array(1 To lastrow)
ReDim sheet2array(1 To lastrowx)
data = Range("A1:Z1000000").Value
For i = LBound(sheet1array, 1) To UBound(sheet1array, 1)
b = "-" & ws.Range("A" & i).Value & "-"
For ii = LBound(sheet2array, 1) To UBound(sheet2array, 1)
If data(i, ii) = InStr(1, ws2.Cells(ii, 1), b) Then
ws3.Range("A" & j) = ws2.Range("A" & ii)
j = j + 1
End If
Next ii
Next i
Debug.Print "Array Time = " & (GetTickCount - T1) / 1000#
Debug.Print "Array Count = " & Format(n, "#,###")
End Sub
Tested with 0.5M entries on sheet1 and 150 on sheet2:
Sub tym()
Dim ws1 As Worksheet, wb As Workbook, ws2 As Worksheet
Dim b, c As Range, rngNums As Range, rngText As Range
Dim dNums, dText, rN As Long, rT As Long, t, m
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
Set c = wb.Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Set rngNums = ws1.Range(ws1.Range("A1"), ws1.Cells(Rows.Count, 1).End(xlUp))
dNums = rngNums.Value
Set rngText = ws2.Range(ws2.Range("A1"), ws2.Cells(Rows.Count, 1).End(xlUp))
dText = rngText.Value
t = Timer
'Method1: use if only one possible match
' (if any number from sheet1 can only appear once on sheet2)
' and sheet2 values are all of format 'text-number-text'
For rT = 1 To UBound(dText, 1)
b = CLng(Split(dText(rT, 1), "-")(1))
m = Application.Match(b, rngNums, 0)
If Not IsError(m) Then
c.Value = dText(rT, 1)
Set c = c.Offset(1, 0)
End If
Next rT
Debug.Print "Method 1", Timer - t
t = Timer
'Method2: use this if conditions above are not met...
For rN = 1 To UBound(dNums, 1)
b = "*-" & dNums(rN, 1) & "-*"
For rT = 1 To UBound(dText, 1)
If InStr(1, b, dText(rT, 1)) > 0 Then
c.Value = dText(rT, 1)
Set c = c.Offset(1, 0)
End If
Next rT
Next rN
Debug.Print "Method 2", Timer - t
End Sub
Method1: ~0.5 sec
Method2: ~17 sec
the find method of a range is faster: https://msdn.microsoft.com/en-us/library/office/ff839746.aspx?f=255&MSPPError=-2147217396
Maybey you could give this a try?
This code expects to find headers for column A on both sheets(1 and 2)
It removes duplicates from column A on Sheet1
It Autofilters Sheet2 for each item on Sheet1
Copies visible rows from Sheet2 to Sheet3
Option Explicit
Public Sub findValues()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, vr As Range
Dim ur1 As Range, ur2 As Range, ur3 As Range, thisRow As Long
Dim i As Byte, ur As Range, itms As Variant, itm As Variant
Set ws1 = Worksheets("Sheet1"): Set ur1 = ws1.UsedRange
Set ws2 = Worksheets("Sheet2"): Set ur2 = ws2.UsedRange
Set ws3 = Worksheets("Sheet3"): Set ur3 = ws3.UsedRange
ur1.RemoveDuplicates Columns:=1, Header:=xlNo
itms = ur1.Columns(1)
If ws2.AutoFilter Is Nothing Then ur2.AutoFilter
Set ur = ur2.Offset(1, 0).Resize(ur2.Rows.Count - 1, ur2.Columns.Count)
Application.ScreenUpdating = False
For Each itm In itms
If i > 0 Then
ur2.Columns(1).AutoFilter Field:=1, Criteria1:="*" & itm & "*"
Set vr = ur2.SpecialCells(xlCellTypeVisible)
If vr.Count > ur2.Columns.Count Then
ur.Copy ur3.Cells(ur3.Rows.Count + 1, ur2.Column)
Set ur3 = ws3.UsedRange
End If
End If
i = i + 1
Next
ws3.Cells(1).EntireRow.Delete
ur2.AutoFilter
Application.ScreenUpdating = True
End Sub