This is what I have so far. I need a sub to copy a group of cells and paste their values on the next empty cell available. The error I'm getting is in selecting that first available cell. Any thoughts?
Dim workline As Integer
Sub Test()
With ActiveSheet
workline = 11
While .Cells(workline, 2) <> Empty
workline = workline + 1
Wend
End With
Range("B3:CH9").Select
Selection.Copy
range(workline,2) .Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Message = MsgBox("Data copied succesfully", vbInformation + vbOKOnly, "Aecon Mining")
End Sub`
Not tested in Excel, but should work, or at least pointing you to the right direction:
Range("B3:CH9").Copy
Range("B2").end(xlDown).offset(1,0).paste 'first available cell
And stop using those .Select and selection everywhere, they are a total waste of time.
Related
I am trying to find the next blank cell in column N in order to select and copy the vale in the same row but in column I after autofiltering column B.
My code seems to find the next blank cell but doesn't take the filter into consideration finding the blank cell in rows not included in the filter.
Hope this makes sense
Edit: Apologies about the shite code, I typically recycle and string it all together etc.
Sub Replanning_Lasers()
startofloop:
Dim Orderbook As String
Dim Supply As String
Orderbook = Sheet25.Range("C14")
Supply = Sheet25.Range("D14")
If Orderbook > Supply Then GoTo endofloop
***Sheets("List").Select
Range("$B$4:$BN$1533").AutoFilter Field:=3, Criteria1:="LASER"
NextFree = Range("N5:" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).row
Range("I" & NextFree).Select***
Selection.Copy
Sheets("Planning").Select
Range("C9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Call BUT_Planning_reset
Call BUT_Planning_Find_First
Range("M9").Select
Selection.Copy
Sheets("List").Select
Range("N" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
GoTo startofloop
endofloop:
End Sub
Thanks
Maybe try something like this:
Sub Replanning_Lasers()
Dim wsList As Worksheet, wsPlan As Worksheet, rngData As Range, rngBlanks As Range
Set wsList = ThisWorkbook.Sheets("List") 'Use variables for worksheets
Set wsPlan = ThisWorkbook.Sheets("Planning") ' to avoid repetition
Set rngData = wsList.Range("B4:BN1533")
rngData.AutoFilter Field:=3, Criteria1:="LASER"
On Error Resume Next 'ignore error if no visible blank cells
'find any visible blank cells in ColN of the filtered data
Set rngBlanks = rngData.EntireRow.Columns("N"). _
SpecialCells(xlCellTypeVisible). _
SpecialCells(xlCellTypeBlanks)
On Error GoTo 0 'stop ignoring errors
If rngBlanks Is Nothing Then Exit Sub 'no visible blanks
For Each c In rngBlanks.Cells 'process each blank cell in turn
If Sheet25.Range("C14") > Sheet25.Range("D14") Then
Msgbox "supply breach"
Exit For 'Orderbook > Supply ?
End If
wsPlan.Range("C9").Value = c.EntireRow.Columns("I").Value 'no need for copy/pastespecial
BUT_Planning_reset 'use of Call is deprecated...
BUT_Planning_Find_First
c.EntireRow.Columns("N").Value = wsPlan.Range("M9").Value
Next c
End Sub
I have a piece of VBA code that is taking data from a spread sheet and formatting it into an input file. This code loops through each column header to makes sure it can find the column its looking for and then offsets by one to get off of the header row and then copies the data to another template.
However this sheet is used by multiple users and the amount of rows being populated can vary so I have set up a variable called rowcount. In this example I'm working on I have 5 records and so I'm trying to select the range from the active cell to the rowcount value (5) but I'm just stuck on the following line:
ActiveSheet.Range(ActiveCell, RowCount).Select
Below is the full code for this section, I know what I'm doing is wrong but any searching via Google throws up results that are too specific and I can't tweak the code to work for me.
If ActiveCell.Value = "Account Name" Then
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
ActiveSheet.Range(ActiveCell, RowCount).Select
Selection.Copy
Sheets("Input").Activate
ActiveSheet.Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Worksheets("Account Details").Select
End If
End If
For someone with more VBA knowledge I'm sure its easy but I'm essentially trying to get highlight Activecell and down to the variable so in this case A5:A10, copy, then paste.
Thanks in advance
Using Select, Activate and ActiveCell is not considered a good practice in VBA. See How to avoid using Select in Excel VBA
However, it takes time to learn to avoid these. Thus, in your code change this line:
ActiveSheet.Range(ActiveCell, RowCount).Select
To this one:
ActiveSheet.Range(ActiveCell, Cells(Rows.Count, ActiveCell.Column)).Select
And if you have rowCount declared and set correctly, then this is a possible option:
Dim rowCount As Long: rowCount = 5
ActiveSheet.Range(ActiveCell.Column, rowCount).Select
First yours,
If ActiveCell.Value = "Account Name" Then
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
ActiveCell.RESIZE(RowCount, 1).Select '<~~ resize to the # of rows
Selection.Copy
Sheets("Input").Activate
ActiveSheet.Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Worksheets("Account Details").Select
End If
End If
Now without Select, Activate or ActiveCell
dim c as variant
with worksheets("sheet1") 'you should know what worksheet you are starting out on
c = application.match("Account Name", .rows(4), 0)
if not iserror(c) then
if .cells(5, c).Value <> "" then
workSheets("Input").Range("C2").resize(RowCount, 1) = _
.cells(5, c).resize(RowCount, 1).value
end if
end if
end with
How to avoid using Select in Excel VBA
Or just use:
ActiveCell.Resize(RowCount,1).Select
Where 1 is number of columns.
At the moment in your range you have just the activecell and row number.
Try something like this:
ActiveSheet.Range(activecell.address &":" &cells(RowCount,ActiveCell.Column).address).select
Don't select the range to copy it; implementing something like this should do the job for you:
Sub Test()
Dim RNG As Range
If ActiveCell.Value = "Account Name" Then
With ActiveSheet
Set RNG = .Range(.Cells(ActiveCell.Row + 1, ActiveCell.Column), ActiveSheet.Cells(.Cells(ActiveSheet.Rows.Count, ActiveCell.Column).End(xlUp).Row, ActiveCell.Column))
End With
RNG.Copy Sheets("Input").Range("C2")
End If
End Sub
I have the following loop to create multiple tabs in Excel 2016 based on a list of PO#'s. ( see code below)
Sub CreateSheetsFromAList()
Dim MyRange As Range
Dim dic As Object, c As Range
Dim k As Variant, tmp As String
Set dic = CreateObject("scripting.dictionary")
Set MyRange = Sheets("Instructions").Range("h6")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Template").Visible = True
For Each c In MyRange
tmp = Trim(c.Value)
If Len(tmp) > 0 Then dic(tmp) = dic(tmp) + 1
Next c
For Each k In dic.keys
If Not WorksheetExists(k) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = k
End If
Next k
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
I also need to populate each newly created tab with info from another workbook (EDI PO Consolidated - 2018.xlsx)
(see code below)
Sub BandB2()
' BandB2 Macro
' Keyboard Shortcut: Ctrl+b
'
Application.Goto Reference:="R20C10"
Selection.Copy
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveSheet.Range("$A$1:$X$2628").AutoFilter Field:=2, Criteria1:= _
"34535453"
Application.Goto Reference:="R1C9"
Range("I2058").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("J26").Select
ActiveSheet.Paste
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveWindow.SmallScroll ToRight:=4
Application.Goto Reference:="R1C17"
Range("Q2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
ActiveWindow.SmallScroll Down:=6
Range("C33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C14"
Range("N2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("D33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C18"
Range("R2058:T2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("E33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I have 2 questions:
1) i cannot make the sheet reference change for each tab; it always picks the
1st po# "34535453"
2) Can you help me combine these into 1 macro.
thank you in advance for your help
Here's a cleaner way to create those tabs.
Name cell H6 on the Instructions tab "PO_Start" or some other appropriate name. That way if you can insert rows or columns on the tab without possibly having to change the reference to H6 in your code.
Sub Create_Sheets()
Dim PO_list, PO As Range
Set PO_list = Range(Sheets("Instructions").Range("PO_Start"), Sheets("Instructions").Range("PO_Start").End(xlDown))
Sheets("Template").Visible = True
For Each PO In PO_list
If Not WorksheetExists(PO) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = PO
End If
Next PO
End Sub
1) To loop through your tabs, if you know that your PO tabs will always start on tab 3, you can loop through the sheets like this (including variable declarations):
Sub B_and_B()
Dim ws As Worksheet
Dim i As Integer
For i = 3 To Sheets.Count
Set ws = Sheets(i)
'... rest of code here
Next i
End Sub
Otherwise if down the road you anticipate adding other sheets besides "Instructions" and "Template" to your Book and Bill file, you could loop through all sheets, error checking to see if you can convert the sheet name to a "long" variable type with Clng(). Probably more than what's needed for your current project.
Another tip:
Avoid using hard-coded cell addresses ("N2058") in your code. If you filter on purchase orders in the Consolidated book and then pull in certain data elements, you'll need to find the row the Purchase Order is in (2058 in this case).
2) To combine these into one macro, you can create a Main subroutine, calling each step separately:
Sub Main()
Call Create_Sheets
Call B_and_B
End Sub
To be short and sweet with my requirement, I need a code to do the conditions below.
Select from range A2:G5
Then check if a sheet named with current date i:e 29-02-2016
If yes,
then copy paste the range in A1 leave 3 rows below for the next data to be pasted below that.
If no,
create a new sheet and name it with current date and then copy paste the range in A1 leave 3 rows below for the next data to be pasted below that.
I tried the below code but it give me error once the current date sheet is created.
Sub Macro1()
Sheets("Sheet1").Select
Range("D3:G12").Select
Selection.Copy
sheets = "todaysdate".select
Dim todaysdate As String
todaysdate = Format(Date, "dd-mm-yyyy")
AddNew:
Sheets.Add , Worksheets(Worksheets.Count)
ActiveSheet.Name = todaysdate
On Error GoTo AddNew
Sheets(todaysdate).Select
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
Try these modifications.
Sub Macro1()
Dim todaysdate As String
With Worksheets("Sheet1")
.Range("D3:G12").Copy
End With
todaysdate = Format(Date, "dd-mm-yyyy")
On Error GoTo AddNew
With Worksheets(todaysdate)
On Error GoTo 0
With .Cells(Rows.Count, "A").End(xlUp).Offset(3, 0)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With
Exit Sub
AddNew:
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = todaysdate
With .Cells(Rows.Count, "A").End(xlUp)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With
End Sub
Step through the modified procedure with the [F8] key to watch how it handles the thrown error and continues on to exit or processes the paste with a three row offset.
I've a problem with my code.
I'm trying to activate a code that take a cell in one sheet and filter the data in another pivot sheets, in case that the value dosen't exist there's a msgbox that show there's an error.
My problem is when the value is true I'd like it to show msgbox "the value dosen't exists in the pivot". when the "if" is false I need to filter the data but it dosen't work.
There's the code:
Sub MM()
Sheets("sheets1").Select
Selection.Copy
Sheets("pivot").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.PivotTables("pivottable1").PivotFields("filter WBS").ClearAllFilters
ActiveSheet.PivotTables("pivottable1").PivotCache.Refresh
If Not IsError(ActiveSheet.PivotTables("pivottable1").PivotFields("filter WBS").CurrentPage = Range("c1").Value) Then
MsgBox ("the value dosen't exists in the pivot")
Sheets("sheets1").Select
Else
ActiveSheet.PivotTables("pivottable1").PivotFields("filter WBS").CurrentPage = Range("c1").Value
End If
End Sub
I'll be glad for some help!
Not totally sure if you wanted to filter the pivot according to what is in the selected cell, but here is my suggestion. To point out there is a way to filter pivot with many values but I supposed you wanted the filter to be done only for one value? Also the way to add filter to pivot is to loop trough all the field values and set them to visible or not visible.
Sub testi2()
'Bit waisty way to do it, you could just make a variable to hold the value -
Dim myValue As Variant
myValue = ActiveCell.Value
'Sheets("sheets1").Select
'Selection.Copy
Sheets("pivot").Select
'Range("C1").Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Your choise tough, if you really need to copy the value to the cell C1 then by all
'means do, but you should still send the value to variable for code will be easier
'to be handled and clearer to read.
'Here you could also clear all past filters for the pivot if needed.
'I won't encourage to but if there are other filters present exept
'what is in filterWBS field, the code will run into an error.
Dim pItem As PivotItem
Dim ifFound As Boolean
ifFound = False
'loop trough the pivotfieldvalues to see if match exists, pivot tables have a need for at least one visible value.
For Each pItem In ActiveSheet.PivotTables("pivottable1").PivotFields("filter WBS").PivotItems
'if data exists then ifFound value will be set to true
If pItem = myValue Then
ifFound = True
End If
Next
'based on the if value found set fields visible or hidden
If ifFound = True Then
For Each pItem In ActiveSheet.PivotTables("pivottable1").PivotFields("filter WBS").PivotItems
If pItem <> myValue Then
pItem.Visible = False
Else
pItem.Visible = True
End If
Next
'if the value was not present show the message box
Else
MsgBox ("the value doesn't exists in the pivot")
'You could in this case clear the filter
End If
End Sub
I found the solution for my problem.
Sub MM()
Sheets("Sheets1").Select
Selection.Copy
Sheets("Pivot").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.PivotTables("pivottable1").PivotFields("filter WBS").ClearAllFilters
ActiveSheet.PivotTables("pivottable1").PivotCache.Refresh
On Error GoTo msg
ActiveSheet.PivotTables("pivottable1").PivotFields("filter WBS").CurrentPage = Range("c1").Value
Exit Sub
msg:
MsgBox ("There is no data for this WBS in pivot")
Sheets("sheets1").Select
End Sub