Vba code to retrieve an entire column from sheet1 if the value in a cell of sheet2 matches the value of a header in sheet1 - excel

I'm trying to find vba code that will bring the contents of an entire column in "sheet1" to "sheet2" if the value in cell A1, matches one of the headers in "sheet1" below is what I have so far:
Sub searchdata()
Dim lastrow As Long, x As Long
lastcolumn = Sheets("Practice Associations").Cells(Columns.Count,.End(xlToRight)
For y = 1 To lastcolumn
If Sheets("Practice Associations").Cells(y, 1).Value = Sheets("Sheet2").Range("A1").Value Then
Sheets("Sheet2").Range("A2:A1000").Value = Sheets("Sheet1").Column(x, 1).Value
Basically, I'm trying to build a dashboard that will pull a list of values if the value searched in a search box matches one of the headers in the table. Any help is appreciated! Thanks in advance.

Hi this code addresses your requirements as it copies the entire column and paste the values on the corresponding matching column in sheet2
Option Explicit
Sub test()
With Excel.Application
.ScreenUpdating = False
End With
Dim last_col_one, last_col_two As Range
Dim sheet_headers As Range
Dim xl_header As Range
Dim target_headers As Range
Dim cell As Range
With ThisWorkbook.Sheets("Sheet2")
Set last_col_one = .Cells(1, .Columns.Count).End(xlToLeft)
Set sheet_headers = .Range(.Cells(1, 1), last_col_one)
End With
With ThisWorkbook.Sheets("Sheet1")
Set last_col_two = .Cells(1, .Columns.Count).End(xlToLeft)
Set target_headers = .Range(.Cells(1, 1), last_col_two)
End With
For Each xl_header In sheet_headers
For Each cell In target_headers
If cell.Value = xl_header.Value Then
cell.EntireColumn.Copy
xl_header.PasteSpecial xlPasteValues
End If
Next cell
Next xl_header
With Excel.Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub

This should work:
Sub Macro3()
myVal = Sheets("Sheet2").Cells(1, 1).Value
t = 1
Found = 0
Do Until Found = 1
If Sheets("Sheet1").Cells(1, t) = myVal Then
Sheets("Sheet1").Columns(t).Copy
Sheets("Sheet2").Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Found = 1
End If
t = t + 1
Loop
End Sub

Related

Delete Row based on Search Key VBA

I am trying to delete every row in which the value "X" is found in column B using VBA. However, I'm having three problems:
I can't get my VBA code to move down from the active cell to the next cell (B3) using cells.find method (see code below)
My code does not delete the entire row where the value "X" is found in column B
The amount of Data in Column B can vary: it can end at B10 today, or B100 tomorrow (see screen shot below)
Any assistance will be greatly appreciated.
Sub RemoveRows()
Dim strLookFor As String
Dim strRow As String
Worksheets("Sheet1").Range("B2").Activate
strLookFor = "X"
strRow = Range("B2").Address
Do Until ActiveCell.Value = ""
MsgBox (ActiveCell.Value)
If ActiveCell.Value = strLookFor Then
Rows.Delete (strRow)
End If
strRow = Cells.Find(what:=strLookFor).Address
Loop
MsgBox ("Deleted all rows with value " & strLookFor)
End Sub
Using an AutoFilter is much more efficient than a range loop
Sub QuickCull()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Sheet1")
Set rng1 = ws.Range(ws.[b2], ws.Cells(Rows.Count, "B").End(xlUp))
Application.ScreenUpdating = False
With ActiveSheet
.AutoFilterMode = False
rng1.AutoFilter Field:=1, Criteria1:="X"
rng1.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
dim x as long
dim r as long
dim sht as worksheet
set sht = Worksheets("Sheet1")
r = sht.Cells(rows.count,2).end(xlup).row
for x = r to 2 step -1
with sht.cells(x,2)
if .value = "X" then .entirerow.delete
end with
next x
This should work:
Sub DeleteRowsWithX()
maxRow = ActiveSheet.UsedRange.Rows.Count
For i = 1 To maxRow
Do While (StrComp(ActiveSheet.Cells(i, 2).Text, "X", vbTextCompare) = 0)
Rows(i).Select
Selection.Delete Shift:=xlUp
Loop
Next
End Sub

Looping and finding similar number in VBA

I am very new to VBA. Just started reading it up 2 days ago. I am wondering how could I write a VB codes assigned to a button to read through the whole column and search for similar numbers.
After that identifying similar numbers, it would need to move on to another column to check if the character in the column are same too.
If both of the logic = true . How can i change the cell of the value of another column?
Sample data
For the current example. The code should know that the first column had matching numbers. After that it will check for the name which is "a" in the example. After that it will automatically change the point to 1 and 0. If there are 3 same ones it will be 1,0,0 for the point
As per image attached in image I am assuming numbers are in Column A, column to check characters is Column J and result needs to be displayed in Column O then try following code.
Sub Demo()
Dim dict1 As Object
Dim ws As Worksheet
Dim cel As Range, fCell As Range
Dim lastRow As Long, temp As Long
Dim c1
Set dict1 = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
c1 = .Range("A2:A" & lastRow)
For i = UBound(c1, 1) To 1 Step -1 'enter unique values with corresponding values in dict1
dict1(c1(i, 1)) = .Range("J" & i + 1) '+1 for Row 2
Next i
Set fCell = .Range("A2")
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A
temp = WorksheetFunction.CountIf(.Range(fCell, cel.Address), cel) 'get count
If temp > 1 Then
If cel.Offset(0, 9) = dict1(cel.Value) Then
cel.Offset(0, 14).Value = 0
Else
cel.Offset(0, 14).Value = 1
End If
Else
cel.Offset(0, 14).Value = 1
End If
Next cel
End With
End Sub
EDIT
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row 'last row with data in Column A
.Range("O2").Formula = "=IF(MOD(SUMPRODUCT(($A$2:$A2=A2)*($J$2:$J2=J2)),3)=1,1,0)" 'enter formula in Cell O2
.Range("O2").AutoFill Destination:=.Range("O2:O" & lastRow) 'drag formula down
.Range("O2:O" & lastRow).Value = .Range("O2:O" & lastRow).Value 'keep only values
End With
Application.ScreenUpdating = True
End Sub
You may try recording whatever you want to do with record macros first, then filter out the codes that are not necessary. If you do not know how to record it using macros, click on the link below. You can learn from the recorded macros and slowly improvise your codes in the future from the experience you may gain.
Here's [a link] (http://www.dummies.com/software/microsoft-office/excel/how-to-record-a-macro-in-excel-2016/)

VBA codes for Excel- Find a cells value in another workbook and copy adjacent cell to the first workbook

I have a quick question; I have two workbooks, let's say wbk1 and wbk2; What I am trying to do is finding each cell value of a column in wbk1 in a specific column of wbk2 and return offset cell value from wbk2 to adjacent cell of the searched value in wbk1.
Is there any one who can help?
By the way, I could find following code if it helps;
'=================
Sub find1()
Dim Key
Dim Target
Dim Hnum
Dim Success
Dim wbk As Workbook
Dim Lastrow As Long
Dim one As Long
Success = False
Application.ScreenUpdating = False
strSecondFile = "C:\Soroush\08- Technical\03- Stock\Test\PL_Test_01\PL_Test_01.xlsm"
strFrthFile = "C:\Soroush\08- Technical\03- Stock\CNC_Test.xlsx"
'==
Sheets("sheet2").Select
Lastrow = ActiveSheet.UsedRange.Rows.Count
If Not IsEmpty(Cells(5, 9).Value) Then
Key = Cells(5, 9).Value
For i = 5 To Lastrow
' If Not IsEmpty(Cells(i, 9).Value) Then
' Key = Cells(i, 9).Value
Set wbk = Workbooks.Open(strFrthFile)
With wbk.Sheets("Sheet1")
Set Target = Columns(1).find(Key, LookIn:=xlValues)
If Not Target Is Nothing Then
ActiveCell.Select
Selection.Copy
Set wbk = Workbooks.Open(strSecondFile)
With wbk.Sheets("Sheet2")
Sheets("Sheet2").Select
Cells(i, 10).Select
ActiveCell.Paste
If Not IsEmpty(Cells(i + 1, 9).Value) Then
Key = Cells(i + 1, 9).Value
End If
End With
End If
End With
'End If
Next
End If
End Sub
'=========================================================================
But It does not work and I can't figure it out. I appreciate any comments on this macro.
Cheers
You can use INDEX and MATCH.
In this case, the value in cell E2 is matched against values in B2 to B6. This is then indexed against column C and the value in column C is returned.
*ignore the typo for "mammal"!

Dynamic Sheet naming and copying data

I have been a silent reader on here for a few months but have been struggling with this code for a week now, so thought i would see if anyone can help.
I have a worksheet where sheet 1 contains information for users to input data.
Column A ask a question, column C is where the user will type in an answer.
Row 4 asks how many configurations there will be. depending on what number they input depends on how many cells light up to the right ie if 1 then D4 goes yellow, if 2 then D4 and E4 go yellow (using conditional formatting)
The user will then enter the title into the highlighted cell (D4,E4 ,F4 etc)
I want to create a new sheet at the end of the sheet for each configuration.
then NAME the new sheet by the text entered in D4, E4 etc.
the code I have so far is:
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 3 To Lastcol
If DoesSheetExist(ActiveSheet.Cells(4 & i).Value) Then
Set tmpSht = ActiveSheet.Cells(4 & i).Value
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(ws)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
I put in "NEWSHEET" to see if even creates a new sheet, but it still fails. I just cant see where I am going wrong.
Any help /advise is welcomed.
EDIT .
I cant work out why though.
The last col will be H4 so lastcol would be "8" .
Then for i = 4 to 8 run the loop. there are descriptions in each of the cells in row 4 so i don't see why it would work for 2 instantness and then fail ?
I dont know if this would make it easier but I have the number of sheets i want to create in cell C4 so i could use this rather than looking up populated cells. so if C4 is 2 then I want to add 2 sheets named as the content of D4, E4. if C4 is 3 then I want to add 3 sheets names as content of D3,E3,F3. Am I making this harder than I need too ?
UPDATE
I figured out the copying over of info is affecting this loop. and amended the code to this.
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
.Rows(13).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
this is doing what i want it to do with a couple of small exceptions.
the Sheets are being named by the cells in D1 , then E13,F13,G13,H13 So i need to figure out where that info is coming from.
the final bit is that due to my conditional formatting in the First sheet, I am getting text on black backgrounds in the copy cells, but that is the very least of my worries !
UPDATE
Found the error -
sShtName = ActiveSheet.Cells(4, i).Value2
should be
sShtName = Worksheets(1).Cells(4, i).Value2
You are calling your cells incorrectly. Use (4, i) instead of (4 & i).
The way you were calling it concatenated it to 43, which resulted in you checking cell AQ1 (AQ being the 43rd column) for the sheet reference.
Edit: I just walked through it a bit and found a couple of other errors. You need to set the sheet name to sht in your 'exists' function, and I'm assuming you want to set tmpSht to a sheet, so you need to encase it in sheets(). Try this:
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
Instead of adding the new sheet and then setting the activesheet to the tmpsht you could use a shorter way (see below). And why did you set the ws if you don't use it....
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = .Cells(4, .Columns.Count).End(xlToLeft).Column
If (Lastcol < 4) Then
Exit Sub
End If
For i = 4 To Lastcol
If (DoesSheetExist(.Cells(4, i).Value2) = True) Then
Set tmpSht = Sheets(.Cells(4, i).Value)
Else
Set tmpSht = Sheets.Add After:=Sheets(Sheets.Count)
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then
DoesSheetExist = True
Else
DoesSheetExist = False
End If
End Function
This was my final code. There were a few tweaks, Firstly I added a formula in row 6 to shorten the name of row 4 to a 10 character name as I found the tab names were too long (hence the code for the naming refers to row 6. I also added some custom text to add into each sheet and some formatting
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer
Dim i As Integer
Dim j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column ' work with the template sheet
If Lastcol = 3 Then Exit Sub 'repeat these steps from the first config to the last
For i = 4 To Lastcol
sShtName = Worksheets(1).Cells(6, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName tmpSht.Name = sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1) ' Format the cell width in the new sheet
.Rows(13).Copy tmpSht.Rows(4)
tmpSht.Range("A1").Value = Worksheets(1).Cells(4, i).Value2
Range("A1").ColumnWidth = 30
Range("B1").ColumnWidth = 0
Range("C1").ColumnWidth = 30
Range("D1:K1").ColumnWidth = 10
Range("D4:J4").Font.Color = vbWhite ' format the colour of the text in the new sheet
Range("C1") = " " ' Negate info in cell C1
With Range("A1:M5") ' add borders
'Clear existing
.Borders.LineStyle = xlNone
'Apply new borders
.BorderAround xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
With Range("A1:C4") ' set colours for the new sheet
.Font.Color = vbBlack
.Interior.Color = vbWhite
End With
Range("D4:J4").Font.Color = vbWhite ' set colour of the numbers to white to show on black background
Range("A5") = "Unit cost in " & Worksheets(1).Cells(17, 3).Value2
Range("A6") = "CUSTOM TEXT ONE."
Range("A7") = "NOTE if quantity " & Range("D4").Value2 + 5 & " is ordered then total cost will be your unit cost for " & Range("D4").Value2 & " multiplied by " & Range("D4").Value2 + 5 & " .This applies up to the quantity of " & Range("E4").Value2 - 1
Range("A8") = "CUSTOM TEXT 2"
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function

VBA copy to another worksheet using multiple if nots

I'm trying to create a code in which certain rows in a workbook are copied to a different workbook. The criteria used are if within these rows column F doesn't have a certain value (so not value 1, 2 or 3) then copy.
I can't quite get it to work. Could someone please assist?
Dim copysheet As Worksheet
Dim pastesheet As Worksheet
Dim Cell As Range
Set copysheet = ActiveWorkbook.Worksheets(1)
Set pastesheet = Workbooks("Workbook1").Worksheets(1)
copysheet.UsedRange.Select
For Each Cell In Selection
If Not Cell.Value = "Value1" Then
If Not Cell.Value = "Value2" Then
If Not Cell.Value = "Value3" Then
ActiveCell.EntireRow.Copy
pastesheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
Next
I would make use of the filter option of excel.
Something like this:
numberofrows = WorksheetFunction.CountA(Sheets("Sheet1").Range("A:A"))
Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, i), Sheets("Sheet1").Cells(numberofrows, i)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Sheet2").Range("A1"), Unique:=True
Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, 1), Sheets("Sheets("Sheet1").Cells(1,1)).AutoFilter Field:=1, Criteria1:=Array(Sheets("Sheet2").Cells(1,1),Sheets("Sheet2").Cells(2,1),...)
Sheets("Sheet1").Cells(1, 1).CurrentRegion.Copy (workbooks("Nike DRS").Sheets("Sheet1").Cells(1, 1))
Option Base 1
Sub t()
Application.DisplayAlerts = False
Dim NewSheet As Worksheet
Dim calsheet As Worksheet
Dim myarr()
Dim myarr1()
myarr1 = Array(1, 2) 'Change the array values which you want to exclude
With ThisWorkbook.Sheets("FINAL DATASET") ' change the raw data sheet name here
.AutoFilterMode = False
Set calsheet = ThisWorkbook.Sheets("cal")
If calsheet Is Nothing Then
Set NewSheet = ThisWorkbook.Sheets.Add
NewSheet.Name = "cal"
Else
ThisWorkbook.Sheets("cal").Delete
Set NewSheet = ThisWorkbook.Sheets.Add
NewSheet.Name = "cal"
End If
.Columns("f").Copy
NewSheet.Range("a1").PasteSpecial (xlPasteValues)
NewSheet.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
For Each cell In NewSheet.Range("a1:a" & NewSheet.Range("a" & Rows.Count).End(xlUp).Row).Cells
i = i + 1
For Counter = 1 To UBound(myarr1)
If cell.Value = myarr1(Counter) Then
k = k + 1
End If
Next Counter
If IsEmpty(k) Then k = 0
If i <> 1 And k = 0 Then
j = j + 1
ReDim Preserve myarr(j)
myarr(j) = cell.Value
End If
k = 0
Next cell
.Rows(1).AutoFilter field:=.Range("f1").Column, Criteria1:=myarr, Operator:=xlFilterValues
End With
End Sub

Resources