Here is a excel vba sub procedure example. I have two columns of data, range v and range c - How could I concatenate each cell rows' value with the parallel row call value.
Ideally, what I am trying to do would be this
For Each c,b In v,bb
...
next c,b
Pleas let me further explain: cell G2 value is only related to J2, and G3 with J3
G2 value = Blue
J2 value = Spaghetti
I am trying to return "Blue Spaghetti" with one for loop?
G2 value = Red
J2 value = Noodles
I am trying to return "Red Noodles" with one for loop?
Dim c As Variant
Dim b As Variant
Dim v As Range
Dim bb As Range
Dim brow As Long
Dim vrow as long
Set v = ActiveSheet.Range("G:G")
vrow = v(v.Cells.Count).End(xlUp).Row
Set v = Range(v(2), v(brow))
Set bb = ActiveSheet.Range("J:J")
brow = bb(bb.Cells.Count).End(xlUp).Row
Set bb = Range(bb(2), bb(brow))
For Each c In v
c = Mid(c, 1, 4)
msgbox c
Next c
For each b in bb
msgbox b
next b
Looking at your original post, I'm going to say I'm confused with all the extra stuff. Look at what goes on here, and comment with questions. I think you are over complicating what you are attempting.
Sub ConcatCols()
Dim lastRow As Long
Dim tempValue As String
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).row
For iRow = 2 to lastRow
tempValue = Sheets("Sheet1").Cells(iRow, "G").Text & " " & _
Sheets("Sheet1").Cells(iRow, "J").Text
MsgBox tempValue
Next iRow
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 have a gigantic table in excel(720x720) in which I want to find non-zero values. when the value is found I would like to get the first two cells of this row on a new sheet on two columns, the cell in question on a third and the first two cells in the columns of the cell I'm looking for on two other columns.
For example if my values are in E26 R89 and Z9 on sheet 1 I would like to get a table on sheet 2 that would look like this:
A B C D E
1 A26 B26 E26 E1 E2
2 A89 B89 R89 R1 R2
3 A9 B9 Z9 Z1 Z2
Here is what I've tried so far (please bear in mind that you are talking to a beginner)
Sub tests_selection()
Dim r As Worksheet
Dim c As Workbook, f As Worksheet
Set c = Workbooks("classeur1")
Set f = c.Worksheets("feuil1")
Dim a(5200)
Dim b
b = 0
Range("A1:AAU723").Select
For i = 4 To 720
For j = 4 To 723
If f.Cells(i, j).Value <> 0 Then
a(b) = f.Cells(i, j).Adress
b = b + 1
End If
Next j
Next i
Set r = c.Worksheets("result")
For i = 0 To b
r.Cells(i, 1).Value = a(i)
Next i
End Sub
Table example
Result example
First of all you should use meaningful variable names instead of 1 character only. This makes your code much more understandable and readable and therefore results in less bugs.
Also use Option Explicit to force proper variable declaring.
Option Explicit
Sub tests_selection()
Dim SrcWs As Worksheet
Set SrcWs = Worksheets("feuil1") 'source worksheet
Dim ResultWs As Worksheet
Set ResultWs = Worksheets("result") 'result worksheet
Dim rRow As Long
rRow = 2 'start row in result sheet
Dim iCell As Range
For Each iCell In SrcWs.Range("C4:AN40") '<-- make sure to adjust the range to the data only! so header rows are not included
If iCell.Value <> 0 Then
ResultWs.Cells(rRow, 1).Value = SrcWs.Cells(iCell.Row, 1).Value
ResultWs.Cells(rRow, 2).Value = SrcWs.Cells(iCell.Row, 2).Value
ResultWs.Cells(rRow, 3).Value = iCell.Value
ResultWs.Cells(rRow, 4).Value = SrcWs.Cells(1, iCell.Column).Value
ResultWs.Cells(rRow, 5).Value = SrcWs.Cells(2, iCell.Column).Value
rRow = rRow + 1
End If
Next iCell
End Sub
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 have 2 sets of data in 2 sheets having same columns in each sheet.
I want to copy both the sets of data from 2 sheets into a 3rd sheet but in the following format:-
Sheet1
Name Age Gender
Mayur 23 M
Alex 24 M
Maria 25 F
April 19 F
Sheet2
Name Age Gender
Mayur 21 M
Maria 24 F
Alex 24 M
June 20 F
Sheet3
Name1 Name2 Age1 Age2 Gender1 Gender2
Mayur Mayur 23 21 M M
Alex Alex 24 24 M M
Maria Maria 25 24 F F
April 19 F
June 20 F
Now there is one primary column i.e. Name. This column will never be empty.
Both the sheets may not have the data in the same sequence.
Both the sheets may have different entries for the same name.
There could be a name missing in any of the sheets
I have written the whole code which does the following:-
I find out Names from sheet1 in sheet2 & then copy corresponding entries for that name from both the sheets to sheet3.
If a name is not found in sheet2 then it's data is copied as it is as shown above & finally Names in sheet2 are searched in sheet1 if any name is not present in there those entries are copied in sheet3.
Now the searching part runs quite well performance wise but the copying part takes a lot of time.
I have tried other methods of copying the data as well but none runs quite fast.
In actual data there are more than 200 columns & millions of rows.
The whole process runs for more than 6-7 hours.
Could anyone please let me know any alternative faster way of achieving this.
Even if that could reduce the time to an hour or 2 from 7 hours that's still great.
Also I need to highlight the descrepancies which I'm doing that by changing the cell color when there is a mismatch in the data while copying from both the sheets.
Below is the code
Sub findUsingArray()
Dim i As Long
Dim j As Variant
Dim noOfColumnsA As Integer
Dim maxNoOfColumns As Integer
Dim noOfRowsA As Long
Dim noOfRowsB As Long
Dim arrayColumnA() As Variant
Dim arrayColumnB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim primaryKeyColumn As Integer
Dim result As Long
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
noOfColumnsA = sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
maxNoOfColumns = noOfColumnsA * 2
noOfRowsA = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
noOfRowsB = sheet2.Cells(Rows.Count, 1).End(xlUp).Row
'createHeader maxNoOfColumns Used to create header in 3rd sheet
primaryKeyColumn = 1
ReDim arrayColumnA(noOfRowsA)
ReDim arrayColumnB(noOfRowsB)
arrayColumnA = sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn))
arrayColumnB = sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn))
result = 2
For i = 2 To noOfRowsA
j = Application.Match(arrayColumnA(i, 1), sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn)), 0)
If Not IsError(j) Then
result = copyInaRowUsingArray(i, result, j, maxNoOfColumns)
Else
result = copyMissingRow(1, i, result, maxNoOfColumns)
End If
Next i
For i = 2 To noOfRowsB
j = Application.Match(arrayColumnB(i, 1), sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn)), 0)
If IsError(j) Then
result = copyMissingRow(2, i, result, maxNoOfColumns)
End If
Next i
End Sub
Function copyInaRowUsingArray(sheet1Index As Long, newRowIndex As Long, sheet2index As Variant, noOfColumns As Integer)
Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet
Dim rowColoured As Boolean
j = 1
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
Set sheet3 = ThisWorkbook.Sheets("Sheet3")
arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheet1Index, 1), sheet1.Cells(sheet1Index, noOfColumns)).Value))
arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheet2index, 1), sheet2.Cells(sheet2index, noOfColumns)).Value))
rowColoured = False
With sheet3
For i = 1 To noOfColumns
valueA = arrayA(j)
If Not valueA = "" Then
.Cells(newRowIndex, i).Value = valueA
End If
i = i + 1
valueB = arrayB(j)
If Not valueB = "" Then
.Cells(newRowIndex, i).Value = valueB
End If
If Not StrComp(CStr(valueA), CStr(valueB)) = 0 Then
If Not rowColoured Then
.Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 35
rowColoured = True
End If
.Cells(newRowIndex, i).Interior.ColorIndex = 34
.Cells(newRowIndex, i - 1).Interior.ColorIndex = 34
End If
j = j + 1
Next i
copyInaRowUsingArray = newRowIndex + 1
End With
End Function
Function copyMissingRow(sheetNo As Integer, sheetIndex As Long, newRowIndex As Long, noOfColumns As Integer)
Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet
j = 1
Set sheet3 = ThisWorkbook.Sheets("Sheet3")
With sheet3
If sheetNo = 1 Then
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
ReDim arrayA(noOfColumns)
arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheetIndex, 1), sheet1.Cells(sheetIndex, noOfColumns)).Value))
For i = 1 To noOfColumns
valueA = arrayA(j)
If Not valueA = "" Then
.Cells(newRowIndex, i).Value = valueA
End If
i = i + 1
j = j + 1
Next i
.Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 46
Else
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
ReDim arrayB(noOfColumns)
arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheetIndex, 1), sheet2.Cells(sheetIndex, noOfColumns)).Value))
For i = 1 To noOfColumns
i = i + 1
valueB = arrayB(j)
If Not valueB = "" Then
.Cells(newRowIndex, i).Value = valueB
End If
j = j + 1
Next i
.Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 3
End If
copyMissingRow = newRowIndex + 1
End With
End Function
As per one of the comments, a dictionary should help do what it is you're after. The dictionary used here saves, from sheet(2), the name as the key and the corresponding row as the value.
Option Explicit
Sub CopyRng(frmSht As Worksheet, frmRow As Integer, offset As Integer, toRow As Integer)
Dim r As Integer
For r = 1 To 3:
Sheets(3).Cells(toRow, offset + 2 * r).Value = frmSht.Cells(frmRow, r).Value
Next
End Sub
Sub InterleaveRows()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Sheets(2)
Dim r As Integer, r2 As Integer, r3 As Integer: r3 = 2
Dim val As String
For r = 2 To .Range("A" & .Rows.Count).End(xlUp).row:
dict(.Cells(r, "A").Value) = r
Next
End With
CopyRng Sheets(1), 1, -1, 1
CopyRng Sheets(2), 1, 0, 1
For r = 2 To Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).row:
val = Sheets(1).Cells(r, "A").Value
If (dict.Exists(val)) Then
r2 = dict(val)
CopyRng Sheets(1), r, -1, r3
CopyRng Sheets(2), r2, 0, r3
dict.Remove val
Else
CopyRng Sheets(1), r, -1, r3
End If
r3 = r3 + 1
Next
For r = 0 To dict.Count - 1
r2 = dict.items()(r)
CopyRng Sheets(2), r2, 0, r3
r3 = r3 + 1
Next
End Sub
The first loop of the 'InterLeaveRows' subroutine populates the dictionary by going through all the entries in Sheet(2). The next two lines writes out the header to sheet(3). The 2nd loop then writes out all values to Sheet(3) that are either in the dictionary (ie in both Sheet(1) and Sheet(2)) or just in Sheet(1); note while doing so entries from the dictionary that are written to Sheet(3) are deleted from the dictionary. The last loop writes out key/val pairs that remain in the dictionary. These are entries that are only in Sheet(2).