I have a workbook with two sheets one named Datadump with headers in row 1 and site and descriptive data in columns A & B and data in column C. I would like to copy this data and paste it in the Worksheet "Factors".
This worksheet has column headers on row 2 and the same descriptive titles in columns A & B. I would like to paste the data from "Datadump" against the same row labels in "Factors" in column E.
However, "Factors" will have some rows which are not in "Datadump" so it needs to paste against relevant rows.
I have tried various code which is not working. Below is the most recent but comes up with a Runtime 1004 error on the pastespecial line.
If anyone could help that would be great.
Thanks
'VARIABLE NAME 'DEFINITION
Dim SourceSheet As Worksheet 'The data to be copied is here
Dim TargetSheet As Worksheet 'The data will be copied here
Dim ColHeaders As Range 'Column headers on Target sheet
Dim MyDataHeaders As Range 'Column headers on Source sheet
Dim DataBlock As Range 'A single column of data
Dim c As Range 'a single cell
Dim Rng As Range 'The data will be copied here (="Place holder" for the first data cell)
Dim i As Integer
Set SourceSheet = Sheets("Datadump")
Set TargetSheet = Sheets("Factors")
With TargetSheet
Set ColHeaders = .Range("A2:E2")
Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
With SourceSheet
Set MyDataHeaders = .Range("A1:C1")
For Each c In MyDataHeaders
If Application.WorksheetFunction.CountIf(ColHeaders, c.value) = 0 Then
MsgBox "Can't find a matching header name for " & c.value & vbNewLine & "Make sure the column names are the same and try again."
Exit Sub
End If
Next c
Set DataBlock = .Range(.Cells(2, 3), .Cells(.Rows.Count, 1).End(xlUp))
Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)
For Each c In MyDataHeaders
i = Application.WorksheetFunction.Match(c.value, ColHeaders, 0)
Set c = DataBlock
If Not c Is Nothing Then
.Columns(c.Column).Copy
c.PasteSpecial xlPasteValues
End If
Next
Application.CutCopyMode = False
End With
End Sub
The below code will do the job,
For i = 2 To 100 'considering 100 rows in Datadump sheet
site1 = Sheets("Datadump").Cells(i, 1).Value
desc1 = Sheets("Datadump").Cells(i, 2).Value
For j = 3 To 50 'considering 50 rows in Factors sheet
site2 = Sheets("Factors").Cells(j, 1).Value
desc2 = Sheets("Factors").Cells(j, 2).Value
If site1 = site2 And desc1 = desc2 Then
Sheets("Factors").Cells(j, 5).Value = Sheets("Datadump").Cells(i, 3).Value
End If
Next j
Next i
Related
I am trying to build a code to check for two conditions simultaneously from my data file. Currently my script works fine because its only checking for the brand name on column A. However I also want to check for the category on column B whether its a "Sun" or "Vista".
Structurally I want something like:
For i = 2 to Last_row
If Cells(i,1).value = "BananaRepublic" and Cells(i, 2).value = "Sun" or "Vista" then,
Row(i).Copy
Worksheet(new_worksheet).Paste
Please note: on an average there are over 30 different brands that I need to enter in this list which need to be matched with their value on column B(Sun/Vista) and I then need to replicate this for 20 different macros each for a different combination of brand names and Sun/Optical category. Doing it individually seems very inefficient. Is there a better solution?
Here's what I've done so far:
Option Compare Text
Sub StarOptical()
'Define all variables
Dim customer_name As String
Dim sheetName As String
sName = ActiveSheet.Name
'ActiveWorkbook.Worksheets(sName).Sort.SortFields.Clear
'Enter the Customer Name here
customer_name = "StarOptical"
Sheets.Add.Name = customer_name
'Copy same header to the new worksheet
Worksheets(sName).Rows(1).Copy
Worksheets(customer_name).Cells(1, 1).Select
ActiveSheet.Paste
'Find the last row of the report
last_row = Worksheets(sName).Cells(Rows.Count, 1).End(xlUp).Row
'Start the loop and scan through each row for listed brands
For i = 2 To last_row
'Update the names of the approved brands in the line below
If Worksheets(sName).Cells(i, 1).Value = "ADENSCO" Or Worksheets(sName).Cells(i, 1).Value = "BANANAREPUBLI" Or Worksheets(sName).Cells(i, 1).Value = "BOSS(HUB)" Then
Worksheets(sName).Rows(i).Copy
Worksheets(customer_name).Activate
last_row_new = Worksheets(customer_name).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(customer_name).Cells(last_row_new + 1, 1).Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
Worksheets(customer_name).Cells(1, 1).Select
End Sub
You can do something like this:
Sub tester()
CreateSheet "BananaRepublic", Array("Sun", "Vista")
'etc for other sheets
End Sub
Sub CreateSheet(sBrand As String, arrVals)
Dim wsSrc As Worksheet, wsDest As Worksheet, i As Long, c As Range
Set wsSrc = ActiveSheet
Set wsDest = wsSrc.Parent.Sheets.Add()
wsDest.Name = sBrand
wsSrc.Rows(1).Copy wsDest.Cells(1, 1)
Set c = wsDest.Cells(2, 1)
For i = 2 To wsSrc.Cells(Rows.Count, 1).End(xlUp).Row
'match on ColA?
If wsSrc.Cells(i, 1).Value = sBrand Then
'match on colB ?
If Not IsError(Application.Match(wsSrc.Cells(i, 2).Value, arrVals, 0)) Then
wsSrc.Rows(i).Copy c 'copy the row
Set c = c.Offset(1, 0) 'next cell down for copy destination
End If
End If
Next
End Sub
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
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/)
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
I have the following data set in my sheet 1
And this template in sheet 3
I wish to
Copy the template from sheet 3 to sheet2
Read the city and name from row 1 in sheet1
Replace the City and Name in sheet 2
Repeat it for every row in sheet 1
So my ideal output will be:
As you can see because we have three rows in sheet 1 the template is copied three times.
I tried this code, but it doesn't go to loop for 'sheet1'
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim ii As Long
Set copySheet = Worksheets("Sheet3")
Set pasteSheet = Worksheets("Sheet2")
For ii = 1 To 10
copySheet.Range("A1:E3").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
Dim j, k, L, b As String
Dim i As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("Sheet1")
Set sht2 = wb.Sheets("Sheet2")
j = "Name"
b = "City"
For i = 1 To 3
k = sht1.Range("A" & i)
L = sht1.Range("B" & i)
sht2.Cells.Replace what:=j, replacement:=k, lookat:=xlWhole, MatchCase:=False
sht2.Cells.Replace what:=b, replacement:=L, lookat:=xlWhole, MatchCase:=False
Next i
Next ii
End Sub
Any guidance is really appreciated.
This isn't what you asked for, but you can accomplish this entirely with cell formulas. It is a little complicated, and VBA is probably a better approach, but in case you're curious:
I am assuming your Name/City pairs are in Sheet1!$A$1:$B$9 **
On sheet 2, in column A, I will build a list that indicates which row to grab data from. (1,1,1,2,2,2,3,3,3,4,4,4, etc)
On sheet 2, column B, I will build a list that shows which type of result this destination row should have (Name - City Name is 1, Name City - City is 2, and Name - City is 3) There are various ways of doing this. I filled Column A with =INT((ROW()-1)/3)+1 and column B with =MOD(ROW()-1,3)+1
Now my first two columns on Sheet 2 look like
Now I can use those to build indexed lookups against the original data. Column C will have 2 different types of behavior. It always starts with the Name, but if Column B is 2, it is followed by the City.
=INDEX(Sheet1!$A$1:$B$9,S A1,1)&IF(B1=2," " & INDEX(Sheet1!$A$1:$B$9, A1,2),"")
Column D will also have two types of entries. Always start with the City, but if Column B is 1, follow with the name.
=INDEX(Sheet1!$A$1:$B$9,A1,2)&IF(B1=1," " & INDEX(Sheet1!$A$1:$B$9,A1,1),"")
Voila
If you wanted to, you could replace all of the references to Columns A & B with the actual formulas that are in them.
Then Column C would have:
=INDEX(Sheet1!$A$1:$B$9,INT((ROW()-1)/3)+1,1)&" "&IF(MOD(ROW()-1,3)+1=2,INDEX(Sheet1!$A$1:$B$9,INT((ROW()-1)/3)+1,2),"")
Make the corresponding substitutions in Column D and you can leave out Columns A&B.
One small inconvenience with this approach is that because it relies on row(), it can't be moved to any other row without adjusting the two index formulas ( INT((ROW()-1)/3)+1 &MOD(ROW()-1,3)+1)
** In the real world, I would also give your source data table a name, like NameCityTable Then your first result column could look like:
=INDEX(NameCityTable,INT((ROW()-1)/3)+1,1)&" "&IF(MOD(ROW()-1,3)+1=2,INDEX(NameCityTable,INT((ROW()-1)/3)+1,2),"")
Try this:
Private Sub CommandButton1_Click()
Dim rng1() As Variant, rng2 As Range, rng3() As Variant,k&
With Worksheets("Sheet1")
rng1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)).Value
End With
With Worksheets("Sheet3")
rng3 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)).Value
End With
With Worksheets("Sheet2")
For k = LBound(rng1, 1) To UBound(rng1, 1)
Set rng2 = .Range("A1").Offset(UBound(rng3, 1) * (k - 1)).Resize(UBound(rng3, 1), UBound(rng3, 2))
With rng2
.Value = rng3
.Replace "City", rng1(k, 2)
.Replace "Name", rng1(k, 1)
End With
Next k
End With
End Sub
Inputs:
Sheet1:
Sheet3:
Output:
Sheet2:
I need to copy an entire row from a sheet and paste in another sheet with same header consider a particular column value is equal to 89581.But my VBA throws 424 error.Please help.
Sub CopyData()
Dim c As Range
Dim Row As Long
Dim sheetUse As Worksheet
Dim sheetCopy As Worksheet
Set sheetUse = Sheets("Data1").Select
Set sheetCopy = Sheets("Data2").Select
Row = 3 'Assume same header in sheet2 as in sheet1
For Each c In sheetUse.Range("O3", Sheet1.Range("O65536").End(xlUp))
If c = 89581 Then
'copy this row to sheet2
Row = Row + 1
c.EntireRow.Copy sheetCopy.Cells(Row, 1)
End If
Next c
Application.CutCopyMode = False
End Sub
Here you go, build a reference to copy then copy and paste in one go.
Sub CopyToOtherSheet()
Dim sheetUse As Worksheet, sheetCopy As Worksheet, i As Long, CopyRange As String
Set sheetUse = Sheets("Data1")
Set sheetCopy = Sheets("Data2")
For i = 3 To sheetUse.Cells(Rows.Count, 15).End(xlUp).Row
If sheetUse.Cells(i, 15) = 89581 Then CopyRange = CopyRange & "," & i & ":" & i
Next i
sheetUse.Range(Right(CopyRange, Len(CopyRange) - 1)).Copy
sheetCopy.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll 'Change to values or formats or whatever you want
Application.CutCopyMode = False
End Sub
Assumed Data1 is the sheet with the data in and Data2 is the one to copy to.
I have the following data set in Sheet1 with headings as you see below:
I want to split the big data set into different sheets by every empty row. Every data set is separated by an empty row, and every data set have values in all cells in columns A and E but their columns B, C, D might have some empty cells randomly. So the defining element to split is the empty rows in column E.
Q1: I want to copy the headings A1:D1 to the new sheets and only copy the columns A:D and not the column E.
Q2: I want to rename new sheets to take the cell value in column E as their name.
So the *results are the following:
Sheet ID1:
Sheet ID2:
Sheet ID3:
I have tried the following code, it works, but it only copies the first table, without renaming the sheet to take the cell value in column E, and it should copy the column E so it should copy only A:D, and it doesn't loop through all tables.
Sub Split_Sheets_by_row()
Dim lLoop As Long, lLoopStop As Long
Dim rMove As Range, wsNew As Worksheet
Set rMove = ActiveSheet.UsedRange.Columns("A:E")
lLoopStop = WorksheetFunction.CountIf(rMove, "Heading5")
For lLoop = 1 To lLoopStop
Set wsNew = Sheets.Add
rMove.Find("Heading5", rMove.Cells(1, 1), xlValues, _
xlPart, , xlNext, False).CurrentRegion.Copy _
Destination:=wsNew.Cells(1, 1)
Next lLoop
End Sub
Your help is very much appreciated.
I've taken a slightly different approach but I have achieved the results you are looking for.
Sub Split_Sheets_by_row()
Dim hdr As Range, rng As Range, ws As Worksheet, wsn As Worksheet
Dim rw As Long, lr As Long, b As Long, blks As Long
Set ws = ActiveSheet
With ws
Set hdr = .Cells(1, 1).Resize(1, 4)
lr = .Cells(Rows.Count, 5).End(xlUp).Row
rw = 2
blks = Application.CountBlank(.Range(.Cells(rw, 1), .Cells(lr, 1))) + 1
For b = 1 To blks
Set rng = .Cells(rw, 1).CurrentRegion
Set rng = rng.Offset(-CBool(b = 1), 0).Resize(rng.Rows.Count + CBool(b = 1), 4)
Set wsn = Worksheets.Add(after:=Sheets(Sheets.Count))
With wsn
.Name = rng.Offset(0, 4).Cells(1, 1).Value
hdr.Copy Destination:=.Cells(1, 1)
rng.Copy Destination:=.Cells(2, 1)
End With
rw = rw + rng.Rows.Count + 1
Set rng = Nothing
Set wsn = Nothing
If rw > lr Then Exit For
Next b
End With
Set rng = Nothing
Set ws = Nothing
End Sub
The header is stored for repeated use and the number of blocks of data are counted by counting the separating blank rows and adding 1. The value from column E is used to rename the worksheet but is not carried across in the data transfer to the new worksheet.
I'm not sure how you would want to handle a worksheet with the same name already existing but they could be deleted before a new worksheet is renamed.