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
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
Here is my current output that my VBscript is generating.
ID DESCRIPTION 1 RECURSIVE_ANALYSIS
CM-1 xxxxxxxxxxxx Issue A
Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B
Sub issue a
Sub issue b
This is following VBA code which i have designed for getting the output
Sub CellSplitter1()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim iTargetRow As Integer
iColumn = 3
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
iTargetRow = 0
With wksSource
lNumCols = .Range("IV1").End(xlToLeft).Column
lNumRows = .Range("A65536").End(xlUp).Row
For J = 1 To lNumRows
CText = .Cells(J, iColumn).Value
Temp = Split(CText, Chr(10))
For K = 0 To UBound(Temp)
iTargetRow = iTargetRow + 1
For L = 1 To lNumCols
If L <> iColumn Then
wksNew.Cells(iTargetRow, L) _
= .Cells(J, L)
Else
wksNew.Cells(iTargetRow, L) _
= Temp(K)
End If
Next L
Next K
Next J
End With
End Sub
Here is my expected output
ID DESCRIPTION 1 RECURSIVE_ANALYSIS Issues
CM-1 xxxxxxxxxxxx Issue A Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B Sub issue a
Sub issue b
So, can someone help me to figure out to get the expected output.
Any help will be much appreciated.
Thank you
it seems you didn't show the whole story, so here's a guessing:
after your code place the following
With wksNew' reference 'wksNew' sheet
With .Range(.Cells(1, iColumn), .Cells(iTargetRow, iColumn)) ' reference its 'iColumn' column range from row 1 down to its last not empty one
.Insert 'insert a new column before referenced range. now the currently referenced range is one column right shifted (i.e. its in the 4th column of referenced sheet)
.Offset(, -1).Value = .Value ' copy values from referenced range one column to the left (i.e. in the newly created column)
.Offset(, -1).Replace "Sub issue*", "", lookat:=xlWhole 'clear the newly created range cells containing "Sub issue..." (hence, there remains cells with "Issue .." only)
.Replace "Issue *", "", lookat:=xlWhole 'clear the currently referenced range (i.e the one in 4th column) cells containing "Issue..." (hence, there remains cells with "Sub issue .." only)
End With
.Columns.AutoFit 'adjust your columns width
End With
Using Variant array is more simple.
Sub test()
Dim r As Long, c As Integer
Dim j As Integer
Dim k As Integer
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim vDB, vSplit, vR()
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
With wksSource
c = .Range("IV1").End(xlToLeft).Column
r = .Range("A65536").End(xlUp).Row
vDB = .Range("a1", .Cells(r, c))
For i = 1 To r
vSplit = Split(vDB(i, c), Chr(10))
For k = 1 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To c + 1, 1 To n)
If k = 1 Then
For j = 1 To c - 1
vR(j, n) = vDB(i, j)
Next j
vR(c, n) = vSplit(k - 1)
vR(c + 1, n) = vSplit(k)
Else
vR(c + 1, n) = vSplit(k)
End If
Next k
Next i
End With
Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub
Here is the sample of my current output which the VBscript code is generating.
[https://i.stack.imgur.com/kMpih.png] [1]:
Here is the sample of my expected output
[[1]: https://i.stack.imgur.com/StBqx.png]
Please let me know your suggestions.
Thank you
I need help with this small project. What I need to accomplished this task is the following:
I have a excel file where my macro button once clicked will read the data from a sheet1 only in column A then should throw the data to another sheet2 and move every data from the sheet1 to sheet2 and display all the data to each separate column.
here is a image of the data example. in the image every circle needs to be in its own column to the new sheet2 that is only part of the data the total of the column rows is around 900.
if need more information please let me know.
here is the code I have it copy the sheet from sheet1 to sheet2 but I need the rest to work
Sub ExportFile()
Dim strValue As String
Dim strCellNum As String
Dim x As String
x = 1
For i = 1 To 700 Step 7
strCellNum = "A" & i
strValue = Worksheets("data").Range(strCellNum).Value
Debug.Print strValue
Worksheets("NewData").Range("A" & x).Value = strValue
x = x + 1
Next
End Sub
Give this a try:
Sub DataReorganizer()
Dim s1 As Worksheet, s2 As Worksheet, N As Long, i As Long, j As Long, k As Long
Dim v As Variant
Set s1 = Sheets("Data")
Set s2 = Sheets("NewData")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 2 Step -1
If s1.Cells(i, "A").Value = "" And s1.Cells(i - 1, "A").Value = "" Then s1.Cells(i, "A").Delete shift:=xlUp
Next i
j = 1
k = 1
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = s1.Cells(i, "A").Value
If v = "" Then
j = 1
k = k + 1
Else
s2.Cells(j, k).Value = v
j = j + 1
End If
Next i
End Sub
you can try this:
Sub ExportFile()
Dim area As Range
Dim icol As Long
With Worksheets("data")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
For Each area In .Areas
icol = icol + 1
Worksheets("NewData").Cells(1, icol).Resize(area.Rows.Count).Value = area.Value
Next
End With
End With
End Sub
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
I am assigning numbers their order in which they appear in the list and i do that using countif function in excel something like this,
=COUNTIF(A$2:A2,A2)
Number Count
10 1
10 2
10 3
11 1
11 2
11 3
12 1
I wish to achieve the same using VBA. However, here are the specifics.
I want to take a variable and compute the countif function and then loop them through.
Once the variable has all numbers(array) I want to paste them in a location.
Assuming column A is sorted as per your list above you could use the following.
Dim arr(100,1) as double '100 = arbitrary number for this example
dim n as double
n=1
arr(roW,0) = Cell(roW + 2, 1).value
arr(roW,1) = n
For roW = 1 to 100
IF Cell(roW + 2, 1).value = Cell(roW + 1, 1).value Then
n = Cell(roW + 2, 1).value
Else
n=1
End if
arr(roW,0) = Cell(roW + 2, 1).value
arr(roW,1) = n
Next
Range("C2:D102")=arr
And another option,
Sub GetUniqueAndCountif()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range, nW As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Sheet1")
Set Rng = sh.Range("A2", sh.Range("A2").End(xlDown))
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
Set nW = Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
nW = vNum
nW.Offset(, 1) = WorksheetFunction.CountIf(Rng, nW)
Next vNum
End Sub
The following code evaluates the results as a single array formula and assigns this to a varaiable v. You can adapt references and add variable declarations as needed.
Sub CountifArray()
v = Evaluate(Replace("INDEX(COUNTIF(OFFSET(y,,,ROW(y)-MIN(ROW(y))+1),y),)", "y", "A2:A8"))
Range("B2:B8") = v
End Sub
This is my suggestion.
Sub Counts()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim lngLastRow As Long
lngLastRow = ws.UsedRange.Rows.Count
Dim Arr() As Variant
'Taking values in column A into an array
Arr = ws.Range("A2:A" & lngLastRow).Value
Dim Arr2() As Variant
'another Array for Countif results
ReDim Arr2(lngLastRow - 2, 0)
Dim count As Long
Dim i As Long, j As Long 'counters
'counting
For i = LBound(Arr) To UBound(Arr)
count = 0
For j = LBound(Arr) To i
If Arr(j, 1) = Arr(i, 1) Then count = count + 1
Next
'filling the array with results
Arr2(i - 1, 0) = count
Next
'sending results back to the worksheet
ws.Range("B2:B" & lngLastRow).Value = Arr2
Set ws = Nothing
End Sub