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
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
I want to screen all sheets for values that starts with "D"
In the sheets I formed blocks (1 column, 4 rows) with
- owner
- area
- parcel (that is allways starting with a "D")
- year of transaction (blocks of 1 column and 4 rows).
I want to make a summary in sheet "Test".
I'm able to find the parcel, but how can I get the info from the cell above?
Sub Zoek_kavels()
Dim ws As Worksheet
Dim rng As Range
Dim Area
Dim Kavel As String
rij = 1
For Each ws In ActiveWorkbook.Sheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell.Value, 1) = "D" Then 'Starts with D
Sheets("Test").Cells(rij, 1) = cell.Value 'Kavel D..
Cells(cell.row - 1, cell.Column).Select
Area = ActiveCell.Value
Sheets("Test").Cells(rij, 2) = Area 'Oppervlakte
Sheets("Test").Cells(rij, 3) = ws.Name 'Werkblad naam
rij = rij + 1
End If
Next
Next
End Sub
A nice simple loop should do the trick, you may have had spaces in the worksheet, that would throw off the used range.
Here is a different approach.
Sub Get_CellAboveD()
Dim LstRw As Long, sh As Worksheet, rng As Range, c As Range, ws As Worksheet, r As Long
Set ws = Sheets("Test")
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:A" & LstRw)
If LstRw > 1 Then
For Each c In rng.Cells
If Left(c, 1) = "D" Then
r = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
ws.Range("A" & r).Value = c
ws.Range("B" & r).Value = c.Offset(-1).Value
ws.Range("C" & r).Value = sh.Name
End If
Next c
End If
End With
End If
Next sh
End Sub
There are two important points (and two not so important) to take care of your code:
start from row 2, because you are using .row - 1. Thus, if you start at row 1, row-1 would throw an error;
try to avoid Select, ActiveCell, etc.;(How to avoid using Select in Excel VBA);
write comments in English, not in Dutch (also good idea for variable names as well, rij or kavel do not help a lot);
declare the type of your variables, e.g. dim Area as String or as Long or anything else;
Option Explicit
Sub ZoekKavels()
Dim ws As Worksheet
Dim rng As Range
Dim Kavel As String
Dim rij As Long
Dim cell As Range
rij = 2 'start from the second row to avoid errors in .Row-1
For Each ws In ActiveWorkbook.Worksheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell, 1) = "D" Then
With Worksheets("Test")
.Cells(rij, 1) = cell
.Cells(rij, 2) = ws.Cells(cell.Row - 1, cell.Column)
.Cells(rij, 3) = ws.Name
End With
rij = rij + 1
End If
Next
Next
End Sub
Or you can use .Cells(rij, 2) = cell.Offset(-1, 0) instead of Cells(cell.Row - 1, cell.Column), as proposed in the comments by #Shai Rado.
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 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