I have 2 sheets which I extract from the system. For sheet1(Data) contain multiple column and all the data inside. For sheet2(Get) I have 2 column, as per below. With reference column no 2 (ID) on sheet2(Get), I want to search this value in the sheet1(Data) then extract specific column value. I try to search online for example code and found this piece of code which extract all column value. But I only want to extract column with highlighted with yellow then extract this value into sheet2(Get). Can help me to modified this code?
Note: For sheet2(Get), all the data on both column A and B already prefilled so I would like to change Worksheet_SelectionChange into a normal sub then run this sub using macro. Possible?
Column C (Get sheet) should extract from Column B (Data sheet)
Column D (Get sheet) should extract from Column M (Data sheet)
Column E (Get sheet) should extract from Column J (Data sheet)
Column F (Get sheet) should extract from Column L (Data sheet)
Column G (Get sheet) should extract from Column C (Data sheet)
Column H (Get sheet) should extract from Column G (Data sheet)
sheet2(Get)
sheet1(Data)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim k As Integer, i As Long, Str As Range
'row number
For i = 3 To Sheets("GetData").Range("a65536").End(3).Row
Set Str = Sheets("Data").Range("a:a").Find(Cells(i, 1).Value, , xlValues, xlWhole)
If Not Str Is Nothing Then
'column number
For k = 1 To 14
If k > 1 Then Sheets("GetData").Cells(i, k).Value = Sheets("Data").Cells(Str.Row, k).Value
Next k
Else
For k = 2 To 14
Sheets("GetData").Cells(i, k).Value = "Null"
Next k
End If
Next i
End Sub
Once you have the row you can copy like this:
Dim col As Long
'...
'...
col = 3
For Each e In Array(2, 3, 7, 10) 'columns to fetch
Sheets("GetData").Cells(i, col).Value = Str.EntireRow.Cells(e).Value
col = col + 1
Next
'...
'...
Public Sub fill_data()
Dim k As Integer, i As Long, Str As Range, col As Long, e As Variant
'row number
For i = 2 To Sheets("GetData").Range("B65536").End(3).Row
Set Str = Sheets("Data").Range("A:A").Find(Cells(i, 2).Value, , xlValues, xlWhole)
If Not Str Is Nothing Then 'if not empty
col = 3
For Each e In Array(13, 2, 10, 3, 5, 12, 9) 'columns to fetch
Sheets("GetData").Cells(i, col).Value = Str.EntireRow.Cells(e).Value
col = col + 1
Next
Else 'if empty
For col = 3 To 9
'Sheets("GetData").Cells(i, col).Interior.ColorIndex = 16 'change cell color OR
Sheets("GetData").Cells(i, col).Value = "NOTFOUND" 'change cell text
Next col
End If
Next i
End Sub
Thank you to Tim Williams for you help.
Related
Trying through this problem in VBA, I've checked a few of the threads here but whatever variant I try I seem to encounter errors I can't resolve.
Sheet 1 Col A has values to match with Sheet 2 Col A, and if matched then the value I want to return in Sheet 1 Col A is contained in Sheet 2 Col B (cell next to value in Col A).
The goal is to:
Check Sheet1 Col A vs Sheet2 Col A for matches.
If Match, output Sheet2 Col B (Sheet2 Col A Offset(0, 1)) to Sheet1 Col B ((Sheet1 Col A Offset(0, 1)).
And so basically to match Sheet1 Col A to Sheet2 Col A, output matched row values from Sheet2 Col B to Sheet1 Col B.
Current attempts (I appreciate there are errors contained, just trying to show logic):
'In this first one I'm trying to iterate through the rows to find the matches and then output offset 0,1 to offset 0,1
Sub loopMatch()
ReDim colA(1 To 22) As Variant
ReDim colB(1 To 27) As Variant
sheet1colA = Worksheets("sheet1").Range("A3:A25").Value
sheet2colA = Worksheets("sheet2").Range("A2:A27").Value
Dim rowCounter1 As Integer
Dim rowCounter2 As Integer
Dim valueFound As Boolean
Dim valueLost As String
valueLost = "The following item(s) are unmatched: "
For rowCounter1 = LBound(sheet1colA) To UBound(sheet1colA)
For rowCounter2 = LBound(sheet2colA) To UBound(sheet2colA)
If sheet2colA(rowCounter2, 1) = sheet1colA(rowCounter1, 1) Then
valueFound = True
Worksheets("sheet1colA").Offset(0, 1).Value = Worksheets("sheet2colA").Offset(0, 1).Value
End If
Next rowCounter2
If valueFound = False Then
valueLost = valueLost & sheet2colA(rowCounter1, 1) & "; "
End If
valueFound = False
Next rowCounter1
Also tried something like:
'This one is just a match search and attempt to output per offset
Sub LoopMatch1()
Dim match
match = Application.match(Worksheets("sheet1").Range("A3:A25").Value, Worksheets("sheet2").Range("A2:A27"), 0)
If Not IsError(match) Then
Worksheets("sheet1").Range("A3:A25").Offset(0, 1).Value = Worksheets("sheet2").Range("A2:A27" & match).Offset(0, 1).Value
Else
Worksheets("sheet1").Range("A3:A25").Offset(0, 1).Value = "Not Found"
End If
Anyone have a better idea of this? Quite new to VBA.
I need a help in excel VBA
I would need to find a text (header - e.g. Account) The cell with word "Account" will be always in the column C
and copy value from adjacent column C and paste them on same sheet to Column A
till the value present in column C (like - 09:00-09:30 till it end )
Column
A B C
Account Test1
Group XXX
Date Mon24 Jun, 2019
09:00-09:30
09:30-10:00
10:00-10:30
10:30-11:00
11:00-11:30
11:30-12:00
12:00-12:30
12:30-13:00
13:00-13:30
17:30-18:00
Account Test2
Group YYY
Date Mon24 Jun, 2019
09:00-09:30
09:30-10:00
10:00-10:30
10:30-11:00
11:00-11:30
11:30-12:00
12:00-12:30
12:30-13:00
13:00-13:30
17:30-18:00
Try this..
Sub ApplyHeader()
Dim c As Range, Acc$, Grp$
'Loops through first to last used i column C
For Each c In Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp))
'Stores value from adjacent cell if it says "Account".
If c.Value = "Account" Then Acc = c.Offset(, 1).Value
'Stores value from adjacent cell if it says "Group".
If c.Value = "Group" Then Grp = c.Offset(, 1).Value
'Applies stored values in columns to the left if first character is numerical.
If IsNumeric(Left(c.Value, 1)) Then
c.Offset(, -2).Value = Acc
c.Offset(, -1).Value = Grp
End If
Next c
'Removes stored values from "memory".
Acc = "": Grp = ""
End Sub
#AsUsual
I have found d way -->
Sub Copy()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Input")
Set Target = ActiveWorkbook.Worksheets("Output")
j = 1
For Each c In Source.Range("C1:C4000")
If IsNumeric(Left(c.Value, 1)) Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
I have and excel document that looks like this:
and i want it to be like:
*comma (,) means that data are in different cells horizontally.
is there any vb macro or an expression to do it?
If all of the Rows have the same number of columns, then you can use INDEX, INT, COUNTA and MOD to break this down.
Column A:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),1)
Column B:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),2+MOD(ROW()-1,COUNTA(Sheet1!$1:$1)-1))
Where Sheet1!$A$1:$D$2 is the 'Input' range, and Sheet1!$1:$1 is any row in that range with a full row of data.
INDEX lets you get a specific row/column of a range. Our Range is Sheet1!$A$1:$D$2, and the Row is the same for both formulae:
1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),
This will be 1 for n rows, 2 for the next n, etc, where n is the number of cells in a row minus the starter column (i.e. how many names per gender)
(INT removes the decimal part of a number, so INT(3/4) is INT(0.75), which is 0. COUNTA just counts the non-blank cells)
The difference between the two is the Column. In column A, we just want the first column, so Column is 1. In column B, we want the xth item after the first column, where x A) counts up by 1 each row and B) resets to 1 when we go from Male to Female (or beyond)
Now, the MOD function lets us do that fairly simply: MOD(0, 3) is 0, MOD(1, 3) is 1, MOD(2, 3) is 2, and MOD(3, 3) is back to 0. We just need to start out row count at 0 (subtract 1 from Row, and add it back outside the MOD) and remove the first column from the items-per-row (subtract 1 from the COUNTA, add 1 outside the MOD)
A straightforward solution would be to use Split
Sub TransferIt()
Const SEP = ","
Dim rg As Range
Dim vdat As Variant
Dim lDat As Variant
Dim i As Long, j As Long
Dim col As Collection
' Assumption data is in column A, adjust accordingly
Set rg = Range("A1:A4")
vdat = WorksheetFunction.Transpose(rg)
Set col = New Collection
For i = LBound(vdat) To UBound(vdat)
lDat = Split(vdat(i), SEP)
For j = LBound(lDat) + 1 To UBound(lDat)
' first field always contains female or male
col.Add lDat(LBound(lDat)) & SEP & lDat(j)
Next j
Next i
vdat = collectionToArray(col)
' Write data into column B
Range("B1").Resize(UBound(vdat) + 1) = WorksheetFunction.Transpose(vdat)
End Sub
' Source: http://www.iwebthereforeiam.com/iwebthereforeiam/2004/06/excel-vba-code-to-convert-coll.html
Function collectionToArray(c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.Item(i)
Next
collectionToArray = a
End Function
Before:
After:
Code:
Sub settupp()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Activate
n = Cells(Rows.Count, 1).End(xlUp).Row
k = 1
For i = 1 To n
namee = Cells(i, 1).Value
For j = 2 To 4
numberr = Cells(i, j).Value
s2.Cells(k, 1) = namee
s2.Cells(k, 2) = numberr
k = k + 1
Next
Next
End Sub
In excel I have column A with some numbers and letters and I would like to extract to a different column all the cells that start with "SIM" (ex, sim 3; sim 4; sim 5) and its correspondent value on column B and column C. I tried different methods using arrays but none worked as you can see the attached link. Link 2 is what I want the result to be.
Thank you very much.
Code tried
Desirable result
This can be achieved with a piece of VBA code. Am checking if the string in Col A starts with "SIM", Then I copy Column A, B, C to Column D, E, F
Change the column names as per your requirements
Sub findsim()
Dim rowcount As Integer
Dim Checkcol1 As Integer, Checkcol2 As Integer, Checkcol3 As Integer, Targetcol As Integer
Dim currentRowValue1 As String
Dim currentRow As Integer, arow As Integer
Checkcol1 = 1 'Denotes A column
Checkcol2 = 2 'Denotes B column
Checkcol3 = 3 'Denotes B column
Targetcol = 4
arow = 1
rowcount = Cells(Rows.Count, Checkcol1).End(xlUp).Row
For currentRow = 1 To rowcount
currentRowValue1 = Cells(currentRow, Checkcol1).Value
If UCase(Left$(currentRowValue1, 3)) = "SIM" Then
Cells(arow, Targetcol).Value = currentRowValue1
Cells(arow, Targetcol + 1).Value = Cells(currentRow, Checkcol2).Value
Cells(arow, Targetcol + 2).Value = Cells(currentRow, Checkcol3).Value
arow = arow + 1
End If
Next
End Sub
Edit
For excel formulas
In first target col say D column, paste this
=IF(UPPER(MID(A1,1, 3)) = "SIM", B1)
In Second target col say E column, paste this
=IF(UPPER(MID(A1,1, 3)) = "SIM", C1)
Note :- You will get blank cells for those which did not have SIM string. you have to manually delete the spaces
I want a macro that can find top 3 values from my sample data between columns B to G, then copy and paste the value to another column in Column Q with the row it is from (within Column A and the row (Row A) it came from.
Eg.
D1 D2 D3
Seq RowA ColumnA
T1 10 20 30 After running macro: T1 D3 30
T2 11 22 2 T2 D2 22
T3 2 3 10 T4 D3 21
T4 6 19 21
Sub Top3()
Dim rng As Range
Dim i As Integer
Dim r As Integer
Range("B2").CurrentRegion.Copy
Range("Q2").PasteSpecial Paste:=xlPasteValues
Range("Q2").CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlDescending
r = 5
For i = 1 To 3
Cells(r, "R") = Cells(r + 1, "A")
Cells(r, "S") = Cells(r + 1, "A")
r = r + 1
Next
Range("B2").CurrentRegion.Clear
Range("C2").Activate
End Sub
Target: All the Cells in the list of values
Target is a range that is 3 Columns x 4 Rows Target.Address = $B$2:$D$5
Target(1) refers to the first cell
Target(Target.Cells.Count) is the last cell
Target(x) is bound by its Columns
Target(4) is the same as saying Target.Cells(2, 1)
Target(x) is not bound by its Rows
The first column in Target is column B and the last row is 5. The next cell outside of the Target range is column B row 6
Target(Target.Cells.Count + 1).Address = $B$6
With this information it we can create a 1 dimensional array of Data that indices and values match that of Target. Using a 1D array makes it easy to reference cells in the Target range using built-in Excel WorksheetFunctions.
Sub GetTop3()
Dim Data
Dim Target As Range
Dim index As Long, x As Long
Set Target = Range("Offset(B1,1,0,Counta(B:B)-1,3)")
ReDim Data(1 To Target.Cells.Count)
For x = 1 To Target.Cells.Count
Data(x) = Target(x)
Next
For x = 2 To 4
index = WorksheetFunction.Match(WorksheetFunction.Max(Data), Data, 0)
With Target(index)
Cells(x, "R") = Rows(.Row).Columns("A")
Cells(x, "S") = Cells(1, .Column)
Cells(x, "T") = .Value
End With
Data(index) = vbNullString
Next
End Sub
This blog shows how to resize a range using the Offset WorksheetFunction: Advanced Excel Dynamic Named Ranges