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
Related
I am not too sure how I should solve this issue, but there are two methods that make sense to me..
Some of the sheets in my workbook do not have headers, so I use the below code to insert a blank row and assign a header to column A - I know column A will always be employee number.
Sub insertRow()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wkbk1 As Workbook
Set wkbk1 = Workbooks("testWorkbook.xlsm")
'Set sheets to be used in each workbook
Set ws1 = wkbk1.Sheets("mySheet")
Set ws2 = wkbk1.Sheets("hisSheet")
Set ws3 = wkbk1.Sheets("herSheet")
wkbk1.Activate
ws1.Range("A1").EntireRow.Insert
ws1.Range("A1").Value = "Employee Number"
ws2.Range("A1").EntireRow.Insert
ws2.Range("A1").Value = "Employee Number"
ws3.Range("A1").EntireRow.Insert
ws3.Range("A1").Value = "Employee Number"
End Sub
The below code deletes columns based on the header name.
Sub ManipulateSheets()
Dim a As Long, w As Long
Dim keepCols As Variant
Dim wkbk1 As Workbook
Set wkbk1 = Workbooks("testWorkbook.xlsm")
keepCols = Array("Employee Number", "Status")
wkbk1.Activate
With wkbk1
For w = 1 To .Worksheets.count
With Worksheets(w)
For a = .Columns.count To 1 Step -1
If UBound(Filter(keepCols, .Cells(1, a), True, vbTextCompare)) < 0 Then _
.Columns(a).EntireColumn.Delete
Next a
End With
Next w
End With
End Sub
The issue is this:
The 3 sheets that I insert a row in and set the column header for column A to Employee Number, still has empty headers for the remainder of the row.. So when I run the code above to delete the columns, nothing happens on these 3 sheets as there is no data to compare to in the header.
So the two options I thought would work are:
Find the lastColumn and insert text into the cells between column A and the lastColumn
Find the lastColumn and include a criteria in the if statement that looks for blank cells as well as non-matching headers
I got the code to find the lastColumn here:
Excel VBA- Finding the last column with data
Sub findColumn()
Dim rLastCell As Range
Dim i As Long
Dim MyVar As Variant
Dim ws1 As Worksheet
Dim wkbk1 As Workbook
i = 2
Set wkbk1 = Workbooks("testWorkbook.xlsm")
Set ws2 = wkbk1.Sheets("ws1")
Set rLastCell = ws2.Cells.Find(What:="*", After:=ws2.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
End Sub
I'm thinking of a Do While Loop along the lines of the below:
Do While (MyVar1 >= 2 And MyVar1 < rLastCell.Column)
Loop
You could change the condition to
IsError(Application.Match(rng.Value, keepCols, 0))
That picks up all non-matching items.
Note:
For Each rng In Intersect(.Rows(1), .UsedRange)
The above is going to loop through the used range of row 1 in the selected sheet.
Looping multiple sheets might be something like:
Option Explicit
Sub test()
Dim keepCols()
keepCols = Array("Employee Number", "Status")
Dim unionRng As Range, rng As Range, ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
If Application.WorksheetFunction.CountA(.Rows(1)) > 0 Then
For Each rng In Intersect(.Rows(1), .UsedRange)
If IsError(Application.Match(rng.Value, keepCols, 0)) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, rng)
Else
Set unionRng = rng
End If
End If
Next rng
If Not unionRng Is Nothing Then
Debug.Print unionRng.EntireColumn.Address 'unionRng.EntireColumn.Delete '. ''<== Swop when ready to delete
Set unionRng = Nothing
End If
End If
End With
Next ws
End Sub
I am trying to loop through all sheets and check them one by one and do the following: If in the checked cell the value of E18 = N/A then on the first sheet (named Summary) I'd change the value of G23 to N/A as well (and then do that for each cell, and on Summary change G23 then G24 then G25 and so forth) I wrote the following loop, it runs but it doesn't do anything whatsoever
Sub MyTestSub()
Dim ws As Worksheet
LastRow = Cells(Rows.Count, "G").End(xlUp).Row
For X = 22 To LastRow
For Each ws In Worksheets
If ws.Range("E18").Value="N/A" then ThisWorkbook.Sheets("Summary").Range("G"&x).Value="N/A"
Next ws
Next x
End Sub
Any help would be appreciated!
It needs to be a 2-Step procedure:
Check if IsError in the cell.
Check if the type of error is #N/A, with If .Range("E18").Value = CVErr(xlErrNA) Then.
Otherwise, if you have a regular String, like "Pass" you will get an error.
Code
Dim lRow As Long
LastRow = Sheets("Summary").Cells(Sheets("Summary").Rows.Count, "G").End(xlUp).Row
lRow = 23 ' start from row 23
For Each ws In Worksheets
With ws
If .Name <> "Summary" Then
If IsError(.Range("E18").Value) Then
If .Range("E18").Value = CVErr(xlErrNA) Then
Sheets("Summary").Range("G" & lRow).Value = CVErr(xlErrNA)
End If
End If
End If
End With
lRow = lRow + 1
Next ws
Try to reverse the nested loops. Something like this should be working:
Sub MyTestSub()
Dim ws As Worksheet
For Each ws In Worksheets
LastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
If IsError(ws.Range("E18")) then
For X = 22 To LastRow
Sheets("Summary").Range("G" & LastRow) = ws.Range("E18")
next x
end if
Next ws
End Sub
Furthermore, I assume that the LastRow is different per worksheet, thus you have to reset it quite often - every time there is a new worksheet.
Last but not least - make sure that you refer the worksheet, when you are refering to Cells, like this:
LastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
If you do not do it you will be taking into account the ActiveSheet.
Here is more about the errors in Excel and returning them - http://www.cpearson.com/excel/ReturningErrors.aspx
The solution will work with any error, not only with #N/A
I need to copy the same worksheet X times (x = sheet2 row A) into a new workbook.
For each copy I need to:
1.Change a drop down to display the next value
2.Do a Refresh (Workbook is connected to a database which pulls different information based on the value of the drop down and is not automatically refreshed)
3.Copy just the values (no formulas)
Rename the sheet to the value of the drop down.
Save all of the copied worksheets into 1 workbook
My code (below) which is called on a button press currently saves the sheet X times based on sheet2 rowA (as intended).
It is missing steps 1,2,4 and 5
The code I have at the moment (called on button click)
Dim x As Integer '~~>Loop counter
Dim WS As Worksheet
Dim LastCellA As Range, LastCellB As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet2") '~~>Sheet with names
With WS
Set LastCellA = .Cells(.Rows.Count, "A").End(xlUp) '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
x = Application.WorksheetFunction.Max(LastCellA.Row)
End With
For numtimes = 1 To x
ActiveWorkbook.Sheets("Sheet1").Copy _
After:=ActiveWorkbook.Sheets(Worksheets.Count)
'~~>Copy values only
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Next
Still... I'm not sure of the point that you "Import" different values based on a drop down. That may be a different macro for loding the data. Then you need to call that macro instead of the .RefreshAll.
Sub test()
Dim uRow As Long, lRow As Long, i As Long
Dim wb As Workbook, ws As Object
With ThisWorkbook
Set ws = .Sheets("Sheet2")
With ws
uRow = .Cells(.Rows.Count, "A").End(xlUp).End(xlUp).Row
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set wb = Workbooks.Add
For i = uRow To lRow
.Sheets("Sheet1").Range("M1").Value = ws.Cells(i, 1).Value '<~~~ this should change the dropdown
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
For Each ws In wb.Sheets
ws.UsedRange.Value = ws.UsedRange.Value
Next
End With
End Sub
EDIT:
If you get trouble with the Sheet2 Column A List (cus it contains empty cells resulting of formulas) you may try a different approach:
Sub test()
Dim wb As Workbook, ws As Worksheet
Dim xVal As Variant
With ThisWorkbook
Set ws = .Sheets("Sheet2")
Set wb = Workbooks.Add
For Each xVal In Intersect(ws.Range("A:A"), ws.UsedRange).Value
If Len(xVal) Then
.Sheets("Sheet1").Range("M1").Value = xVal
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
wb.Sheets(wb.Sheets.Count).UsedRange.Value = wb.Sheets(wb.Sheets.Count).UsedRange.Value
End If
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
End With
End Sub
Based on the code you provided, I believe this is what you are looking for.
It will loop through your list, copy sheet1 to the new workbook and name the sheet.
I am not sure what you want with looping through your dropdown list.
Sub Button1_Click()
Dim wb As Workbook, Bk As Workbook
Dim WS As Worksheet, sh As Worksheet
Dim LastCellA As Long, LastCellB As Range, c As Range
Dim LastCellRowNumber As Long
Dim x As Integer '~~>Loop counter
Set wb = ThisWorkbook
Set WS = wb.Worksheets("Sheet2") '~~>Sheet with names
Set sh = wb.Sheets("Sheet1")
With WS
LastCellA = .Cells(.Rows.Count, "A").End(xlUp).Row '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
Set LastCellB = .Range("A1:A" & LastCellA).SpecialCells(xlCellTypeConstants, 23)
End With
Set Bk = Workbooks.Add
For Each c In LastCellB.Cells
sh.Range("M1") = c
sh.Copy After:=Bk.Sheets(Worksheets.Count)
With ActiveSheet
'~~>Copy values only
.UsedRange.Value = .UsedRange.Value
.Name = c
End With
Next c
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
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