I have two excel sheets and I need to do a cell comparison.
Need a Macro solution.
Sheet 1 have column A-N and Sheet 2 have column A-S
I need to first check whether each column B values (B1:B2000) in sheet 1 available in Column F in Sheet 2.
If available then select the value in column A in shee2 and paste that in the Column O in sheet 1.
Sorry for the detail question without putting any effort.
Can't find anyway to enter to this question...
Give this a go,
Sub Button1_Click()
Dim ws As Worksheet, sh As Worksheet
Dim wsRws As Long, wsRng As Range, w As Range
Dim shRws As Long, shRng As Range, s As Range
Set ws = Sheets("Sheet1")
Set sh = Sheets("Sheet2")
With ws
wsRws = .Cells(Rows.Count, "B").End(xlUp).Row
Set wsRng = .Range(.Cells(1, "B"), .Cells(wsRws, "B"))
End With
With sh
shRws = .Cells(Rows.Count, "F").End(xlUp).Row
Set shRng = .Range(.Cells(1, "F"), .Cells(shRws, "F"))
End With
For Each w In wsRng
For Each s In shRng
If w = s Then w.Offset(0, -1) = s.Offset(0, -5)
Next s
Next w
End Sub
Related
I'm trying to create a fairly simple book in/out system
We track the item from delivery confirmation --> arrival on site --> dispatch from site with a register at each point
I've got all the coding sorted except deleting the record once the item is copied to the next stage
IE:
ITEM 1 is in the 'awaiting delivery' sheet with all its relevant info, it's details get pulled across onto the 'entry to site' form where more info is added then when an input button is pressed, this data is copied to the 'on site' register and I need the code to then delete the old record
In my head it would be a code to use one cell (B1, sheet 2) to find the matching record in the previous sheet (searching in row A:A of sheet 1) and then deleting the row with that record
Thank you! (I'm very much a VBA newbie that's been thrown in the deepend so will try help as much as I can!)
Delete sheet1 rows that = sheet2 range("B1")
Sub Delete_B1()
Dim Sh As Worksheet, ws As Worksheet
Dim LstRw As Long, FrNg As Range, x
Set Sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
Set FrNg = ws.Range("B1")
With Sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
For x = LstRw To 1 Step -1
If .Cells(x, 1) = FrNg Then .Cells(x, 1).EntireRow.Delete
Next x
End With
End Sub
If you want to delete the A:N cells, then shift cells up.
Sub Delete_B1()
Dim Sh As Worksheet, ws As Worksheet
Dim LstRw As Long, FrNg As Range, x
Set Sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
Set FrNg = ws.Range("B1")
With Sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
For x = LstRw To 1 Step -1
If .Cells(x, 1) = FrNg Then
.Range("A" & x & ":N" & x).Delete Shift:=xlUp
End If
Next x
End With
End Sub
I have a master worksheet that contains data with many columns.
Next I have also created multiple worksheets from a list.
Now, I would like to copy the rows from the master worksheet to the respective worksheets if the value in the column matches against all the worksheet name, else copy to an 'NA' sheet.
Previously I could only think of hardcoding, but it is not feasible because the number of worksheets may increase to 50+, so I need some help on how I can achieve this..
'find rows of master sheet
With sh
LstR = .Cells(.Rows.Count, "C").End(xlUp).Row 'find last row of column C
Set rng = .Range("C3:C" & LstR) 'set range to loop
End With
'start the loop
'loop through, then loop through each C cell in template. if cell.value == worksheet name, copy to respective worksheet... elseif... else copy to NA
For Each c In rng.Cells
If c = "WEST" Then
c.EntireRow.Copy wsl1.Cells(wsl1.Rows.Count, "A").End(xlUp).Offset(1) 'copy row to first empty row in WEST
ElseIf c = "PKM" Then
c.EntireRow.Copy wsl2.Cells(wsl2.Rows.Count, "A").End(xlUp).Offset(1)
Else
c.EntireRow.Copy wsl7.Cells(wsl7.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
Thanks to #user9770531, I was able to do what I want for the macro.
However, now I would like to make the macro more flexible.
For example, I have this additional table in another worksheet with
ColA_id and ColB_group
Instead of just matching checking worksheet name against the values in column C, I would like to do this:
if the master file column C matches "ColA_id", copy the data to respective "ColB_group" worksheets. Assuming ColB_group have been used to create the worksheet names.
Use code bellow - all subs in the same (standard) module
It searches Master.ColumnC for each sheet name (except Master and NA)
Uses AutoFilter for each sheet name, and copies all rows at once
All rows not assigned to a specific sheet will be copied to NA
It assumes sheet NA is already created, with Headers
Option Explicit
Const NA_WS As String = "NA" 'Create sheet "NA" if it doesn't exist
Public Sub DistributeData()
Const MASTER_WS As String = "Master"
Const MASTER_COL As String = "C" 'AutoFilter column in Master sheet
Dim wb As Workbook
Set wb = Application.ThisWorkbook
Dim ws As Worksheet, lr As Long, lc As Long, ur As Range, fCol As Range, done As Range
With wb.Worksheets(MASTER_WS)
lr = .Cells(.Rows.Count, MASTER_COL).End(xlUp).Row
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set ur = .Range(.Cells(3, 1), .Cells(lr, lc))
Set fCol = .Range(.Cells(2, MASTER_COL), .Cells(lr, MASTER_COL))
Set done = .Range(.Cells(1, MASTER_COL), .Cells(2, MASTER_COL))
End With
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
If ws.Name <> MASTER_WS And ws.Name <> NA_WS Then
fCol.AutoFilter Field:=1, Criteria1:=ws.Name
If fCol.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
UpdateWs ws, ur
Set done = Union(done, fCol.SpecialCells(xlCellTypeVisible))
End If
End If
Next
If wb.Worksheets(MASTER_WS).AutoFilterMode Then
fCol.AutoFilter
UpdateNA done, ur
End If
Application.ScreenUpdating = True
End Sub
Private Sub UpdateWs(ByRef ws As Worksheet, ByRef fromRng As Range)
fromRng.Copy
With ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
.PasteSpecial xlPasteAll
End With
ws.Activate
ws.Cells(1).Select
End Sub
Private Sub UpdateNA(ByRef done As Range, ByRef ur As Range)
done.EntireRow.Hidden = True
If ur.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
UpdateWs ThisWorkbook.Worksheets(NA_WS), ur.SpecialCells(xlCellTypeVisible)
End If
done.EntireRow.Hidden = False
Application.CutCopyMode = False
ur.Parent.Activate
End Sub
Hi there I am trying to select a range "A2:H2" down to the last filled cell based on column A (so in this case it should select "A2:H59"). The range is not fixed so it cannot be defined with exact numbers. I have the following code, but it selects everything down to the 402nd row even though there is no data beyond "A59" in the sheet. Any idea what is going on? Thanks for the help!
Global ssaw As Worksheet
Global trckr As Worksheet
Sub DataF()
Dim myRange As Range
Dim myCell As Range
Set ssaw = Sheets("SSAW_DATA")
Set trckr = Sheets("SQL_DATA_FEED")
Set myRange = trckr.Range("A2:H2").end(xlDown)
With myRange
.SpecialCells(xlCellTypeBlanks).Interior.Color = RGB(255, 102, 102)
.SpecialCells(xlCellTypeBlanks).Value = "#missing#"
End With
End Sub
If we assume your last used cell in column A is A59 then …
… This
Set myRange = trckr.Range("A2", trckr.Range("A2").End(xlDown))
will select A2:A59 and this
.Resize(ColumnSize:=8)
will resize it to make it 8 columns width that is A2:H59.
So together we get:
Set myRange = trckr.Range("A2", trckr.Range("A2").End(xlDown)).Resize(ColumnSize:=8)
Use this
trckr.Range("A" & trckr.Rows.Count).End(xlUp)
alternatively to find the last used cell in column A if there can be empty cells in between:
Set myRange = trckr.Range("A2", trckr.Range("A" & trckr.Rows.Count).End(xlUp)).Resize(ColumnSize:=8)
exploit the fact that Range(cell1, cell2) is equivalent to Range(cell2, cell1)
Set myRange = trckr.Range("H2", trckr.Range("A2").End(xlDown))
while if you want to select a range from A2:H2 down to column A last not empty cell (i.e. included empty cells along column A in between the first and last not empty ones):
Set myRange = trckr.Range("H2", trckr.Cells(trckr.Rows.Count, 1).End(xlUp))
I would suggest to use the following code
Option Explicit
Function LastRowInColumn(colName As String)
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, colName).End(xlUp).Row
End With
LastRowInColumn = lastRow
End Function
Sub SelectRg()
Dim rg As Range
Dim wks As Worksheet
Dim lastRow As Long
lastRow = LastRowInColumn("A")
Debug.Print lastRow
If lastRow = 1 Then
' do nothing
Else
Set wks = ActiveSheet
With wks
Set rg = Range(.Cells(2, 1), .Cells(lastRow, "H"))
rg.Select
End With
End If
End Sub
The code determins the last filled row in column A and select based on this information everything to column H
EDIT Improved function
Function LastRowInColumn(ByVal wks As Worksheet, ByVal colName As String) As Long
With wks
LastRowInColumn = .Cells(.Rows.Count, colName).End(xlUp).Row
End With
End Function
EDIT2 And if one would not like to use an extra function you could do it like that
Sub SetRg()
Dim rg As Range
Dim wks As Worksheet
Dim lastRow As Long
Set wks = ActiveSheet
With wks
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'lastRow = LastRowInColumn(wks, "A")
If lastRow > 1 Then
Set rg = Range(.Cells(2, 1), .Cells(lastRow, "H"))
End If
End With
End Sub
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.
I am trying to copy value from two specific cells to specific cells in another sheet.
Problem is that I have many cells in first sheet and some of them are empty. Also paste is always 99 times, just range changes. Is there a loop to make everything more easy?
Here is my attempt
Sub copytry()
Worksheets("sheetI").Range("I17:J17").Copy _
Destination:=Worksheets("sheetII").Range("F1352:F1451")
Worksheets("sheetI").Range("I18:J18").Copy _
Destination:=Worksheets("sheetII").Range("F1452:F151")
End Sub
Practice using this,
Sub copytry()
Dim ws As Worksheet
Dim sh As Worksheet, lstrw As Long
Dim Rws As Long, Rng As Range, c As Range
Set ws = Worksheets("sheetI")
Set sh = Worksheets("sheetII")
With ws
Rws = .Cells(Rows.Count, "I").End(xlUp).Row
Set Rng = .Range(.Cells(17, "I"), .Cells(Rws, "I"))
For Each c In Rng.Cells
If c = "" Then c = "." 'Added to Code
lstrw = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
c.Range("A1:B1").Copy Destination:=sh.Range(sh.Cells(lstrw, 1), sh.Cells(lstrw + 99, 1))
Next c
End With
End Sub