Have VBA knowledge but cannot make the below formula worl.
Problem: create a new line and add an "S" into the column C but new row line.
Insert into column E (new row line) the name of the active sheet created.
Continuously create new lines in succession throughout the year.
NewName = InputBox("Debit note Number")
Range("Table1[[#Headers],[Supplier]]").Select
Selection.End(xlDown).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.ClearContents
OneMore = False
See documentation for ListObjects
Option Explicit
Sub insertRow()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim oTbl As ListObject, oListRow As ListRow
Set oTbl = ws.ListObjects.Item("Table1")
Set oListRow = oTbl.ListRows.Add
oListRow.Range.Value = oListRow.Range.Offset(-1, 0).Value
oListRow.Range.Cells(1, 3).value = "S"
oListRow.Range.Cells(1, 5).value = "New Sheet"
End Sub
Related
Excel starts with two sheets.
First a list which includes data for a name, a number, and a product numbers.
The second tab is a template.
I'm trying to:
Copy the template tab, input the name, number, and product into the new tab, and then rename the tab (ActiveSheet.Name = Range("B3").Value).
Loop down to the next row and repeat until there are no more rows.
If a tab already exists with the name, then move onto the next row.
I tried two methods.
The code below I could probably figure out but it would require me to copy and paste the same lines with updated rows about 100 times since it isn't looping.
Also, the macro stops if there's already a tab with the name on it instead of continuing.
I made several attempts to have the macro move on if a tab has already been created from a name on the list but this keeps breaking the macro.
Sub TemplateMultiple()
'
' Tab creation and naming
'
'
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(2)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!RC[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(3)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[3]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[0]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(4)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[4]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[1]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(5)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[5]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[3]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(6)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[6]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[4]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[3]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
End Sub
The second method involves a loop to make the code much easier to read/follow.
My code is putting the same information into each template instead of going down one row for each spreadsheet.
Sub Template1()
'UpdatebyExtendoffice20161222
Dim x As Integer
Application.ScreenUpdating = False
' Set numrows = number of rows of data.
NumRows = Range("B5", Range("B5").End(xlDown)).Rows.Count
' Select cell a1.
Range("B5").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
' Insert your code here.
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(2)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!RC[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
Something like this should work:
Sub Template1()
Dim wb As Workbook, ws As Worksheet, wsList As Worksheet
Dim c As Range, sheetName As String, wsTempl As Worksheet
Set wb = ThisWorkbook
Set wsList = wb.Worksheets("List")
Set wsTempl = wb.Worksheets("Template")
Application.ScreenUpdating = False
For Each c In wsList.Range("B5", wsList.Cells(Rows.Count, "B").End(xlUp)).Cells
sheetName = c.Value
Set ws = GetWorksheet(wb, sheetName) 'see if there's an existing sheet with this name
If ws Is Nothing Then 'if was no matching sheet
wsTempl.Copy before:=wsTempl 'copy template in front of itself
Set ws = wb.Worksheets(wsTempl.Index - 1) 'get a reference to the copy
ws.Name = sheetName
With c.EntireRow
'I never use R1C1 so this might be off...
ws.Range("B3:C3").Formula = "='List'!" & .Columns("B").Address(False, False)
ws.Range("B5:C5").Formula = "='List'!" & .Columns("E").Address(False, False)
ws.Range("B6:C6").Formula = "='List'!" & .Columns("E").Address(False, False)
End With
End If
Next c
Application.ScreenUpdating = True
End Sub
'Return a worksheet named `wsName` from workbook `wb`, or `Nothing` if it doesn't exist
Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = wb.Worksheets(wsName)
On Error Goto 0
End Function
Note there's rarely any need to select/activate things before you work with them - that's an artifact of the macro recorder.
See How to avoid using Select in Excel VBA for more on this and some good guidelines to follow.
I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
My problems are:
The number of rows is different everytime. (manual effort)
Columns are not in order.
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"
'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
Best way of doing it
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
Sub selectVisibleRange()
Dim DbExtract, DuplicateRecords As Worksheet
Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")
DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Cells(1, 1).PasteSpecial
End Sub
I suggest you do it a different way.
In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")
Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
'I went from the cell row3/column6 (or F3) and go down until the last non empty cell
i = 2
For Each rCell In SportsRange 'loop through each cell in the range
If rCell = "hockey" Then 'check if the cell is equal to "hockey"
i = i + 1 'Row number (+1 everytime I found another "hockey")
HokySh.Cells(i, 2) = i - 2 'S No.
HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age
End If
Next rCell
End Sub
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
Example:
Sub copy()
'source worksheet
dim ws as Worksheet
set ws = Application.Worksheets("Data")' set you source worksheet here
dim data_end_row_number as Integer
data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
'enable filter
ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
Application.Worksheets("Hoky").Range("B3").Paste
'You have to add headers to Hoky worksheet
end sub
it needs to be .Row.count not Row.Number?
That's what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets("Export (2)") 'Data Source
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy
I am new to VBA. I am trying to input values from multiple sheets into a "header" block that I have created on my master spreadsheet. I have multiple sheets with the same information but specific to that set of data. I have figured out how to do the first header block from the first sheet of data. Now I am wondering if I can create a loop that offsets the information a certain amount and input the information for the next remaining sheets. If possible I want it to not depend on how many sheets are imported. Whether 1 sheet or 50 sheets. Thanks!
Here is my code:
Private Sub Generate_Click()
'Set Header info for Raw Data
'Program Name Entry Sheet 2
ActiveSheet.Next.Activate
Dim Part As Range
Set Part = ActiveSheet.Range("B1:B10").Find("Part Name")
Part.Offset(0, 1).Select
Selection.Copy
Sheets("Variable Data").Select
Dim PName As Range
Set PName = ActiveSheet.Range("A1:AA10").Find("Program Name")
PName.Offset(0, 1).Select
ActiveSheet.Paste
'Program Rev Entry Sheet 2
ActiveSheet.Next.Activate
Dim Rev As Range
Set Rev = ActiveSheet.Range("B1:B10").Find("Revision Number")
Rev.Offset(0, 1).Select
Selection.Copy
Sheets("Variable Data").Select
Dim PRev As Range
Set PRev = ActiveSheet.Range("A1:AA10").Find("Program Rev")
PRev.Offset(0, 1).Select
ActiveSheet.Paste
'Program Date Entry Sheet 2
ActiveSheet.Next.Activate
Dim PDate As Range
Set PDate = ActiveSheet.Range("B1:B10").Find("Date")
PDate.Offset(0, 1).Select
Selection.Copy
Sheets("Variable Data").Select
Dim RDate As Range
Set RDate = ActiveSheet.Range("A1:AA10").Find("Run Date")
RDate.Offset(0, 1).Select
ActiveSheet.Paste
'Program Lot Entry Sheet 2
ActiveSheet.Next.Activate
Dim Serial As Range
Set Serial = ActiveSheet.Range("B1:B10").Find("Serial Number")
Serial.Offset(0, 1).Select
Selection.Copy
Sheets("Variable Data").Select
Dim Lot As Range
Set Lot = ActiveSheet.Range("A1:AA10").Find("Lot Number")
Lot.Offset(0, 1).Select
ActiveSheet.Paste
End Sub
EDIT: you can take an approach like this
Private Sub Generate_Click()
'Set Header info for Raw Data
Dim wb As Workbook, ws As Worksheet, wsVD As Worksheet
Dim rngVDHeaders As Range, rowOffset As Long
Set wb = ThisWorkbook
'summary sheet and headers
Set wsVD = wb.Worksheets("Variable Data")
Set rngVDHeaders = wsVD.Range("A1:AA10")
rowOffset = 1 'starting offset from header row
'loop over all worksheets
For Each ws In wb.Worksheets
'excluding the summary sheet
If ws.Name <> wsVD.Name Then
'find and copy values to summary sheet
With ws.Range("B1:B10")
.Find("Part Name").Copy rngVDHeaders.Find("Program Name").Offset(rowOffset, 0)
.Find("Revision Number").Copy rngVDHeaders.Find("Program Rev").Offset(rowOffset, 0)
.Find("Date").Copy rngVDHeaders.Find("Run Date").Offset(rowOffset, 0)
.Find("Serial Number").Copy rngVDHeaders.Find("Lot Number").Offset(rowOffset, 0)
End With
End If
rowOffset = rowOffset + 1 'next line down
Next ws
End Sub
I have written a code which does the below steps.
1) Loops through a list of products
2) Auto filters the data with each product.
3) Copies and pastes data on to separate worksheets and names it with that product name.
4) Inserts a line at every change in schedule
The only thing I couldn't do it here is to limit separate worksheet creation only for the products available in the source data when auto filtered.
I tried to do this by adding an if condition to add worksheets by product name only if auto filter shows any data but for some reason it is not working.
I would appreciate any help in fixing this problem and clean my code to make it look better and work faster.
Sub runreport()
Dim rRange As Range
Dim Rng As Range
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
Next producttype
End Sub
Try this...
Sub runreport()
Dim rRange As Range
Dim Rng As Range
Dim FiltRows As Integer
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
With Workbooks("Source.xlsx").Sheets("Sheet1")
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
End With
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
Next producttype
End Sub
I would recommend you define more variables than you have it keeps the code cleaner and easier to read as well as eliminates easy errors.
I also recommend always to utilize "option explicit" at the top of every code. It forces defining all variables (when you don't define a variable the program will do it for you (assuming you haven't used option explicit), but excel doesn't always get it correct. Also option explicit helps you avoid typos in variables.
Also as a general rule you rarely if ever have to .select anything to do what you need to with vba.
Below is an example of a cleaned up and shortened code which utilized variable definition and instantiation.
Sub runreport()
Dim wb As Workbook
Dim wsSched As Worksheet
Dim wsNew As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rRange As Range
Dim producttype As Range
Dim Filename As String
Dim FiltRows As Integer
Dim myRow As Integer
'instantiate Variables
Set wb = ThisWorkbook
Set wsSched = wb.Worksheets("Schedule")
' Open the Source File
Filename = Application.GetOpenFilename()
Set wbSource = Workbooks.Open(Filename)
Set wsSource = wbSource.Worksheets("Sheet1")
'Loops through each product type range from the macro spreadsheet.
For Each producttype In wsSched.Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
With wsSource
.AutoFilterMode = False
.Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
'Add new workbook
Set wsNew = wb.Sheets.Add(After:=ActiveWorkbook.Sheets(Sheets.Count))
'Copy filtered data including header
.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
'Paste filterd data and header
wsNew.Range("A1").PasteSpecial
Application.CutCopyMode = False
wsNew.Columns.AutoFit
'Rename new worksheet
wsNew.Name = WorksheetFunction.VLookup(producttype, wb.Worksheets("Sheet2").Range("A:B"), 2, False)
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
End With
Next producttype
End Sub
First, you can check this answer for ways to optimize your vba code
As for your code in its current form, it would be easiest if you select the entire range of your product code data first. Then you can check this range after your filter and determine if all the rows are hidden. See a sample of the code below
Dim productData as Range
Set productData = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter _
Field:=4, Criteria1:=producttype
' The error check will skip the creation of a new sheet if the copy failed (i.e. returns a non-zero error number)
On Error Resume Next
' Copies only the visible cells
productData.SpecialCells(xlCellTypeVisible).Copy
If Err.number = 0 then
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = Application.VLookup(producttype, _
ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
Range("a2").Select
ActiveSheet.Paste
End If
While you can Range.Offset one row and check if the Range.SpecialCells method with xlCellTypeVisible is Not Nothing, I prefer to use the worksheet's SUBTOTAL function. The SUBTOTAL function discards hidden or filtered rows from its operations so a simple COUNTA (SUBTOTAL subfunction 103) of the cells below the header will tell you if there is anything available.
Sub runreport()
Dim rRange As Range, rHDR As Range, rVAL As Range, wsn As String
Dim fn As String, owb As Workbook, twb As Workbook
Dim i As Long, p As Long, pTYPEs As Variant
pTYPEs = ThisWorkbook.Sheets("Schedule").Range("Product").Value2
Set twb = ThisWorkbook
' Open the Source File
fn = Application.GetOpenFilename()
Set owb = Workbooks.Open(fn)
With owb
'is this Workbooks("Source.xlsx")?
End With
With Workbooks("Source.xlsx").Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
'store the header in case it is needed for a new worksheet
Set rHDR = .Rows(1).Cells
'reset the the filtered cells
Set rVAL = Nothing
For p = LBound(pTYPEs) To UBound(pTYPEs)
.AutoFilter Field:=4, Criteria1:=pTYPEs(p)
With .Resize(.Rows.Count - 1, 7).Offset(1, 0) '<~~resize to A:G and move one down off the header row
If CBool(Application.Subtotal(103, .Cells)) Then
'there are visible cells; do stuff here
Set rVAL = .Cells
wsn = Application.VLookup(pTYPEs(p), twb.Worksheets("Sheet2").Range("A:B"), 2, False)
'if the wsn worksheet doesn't exist, go make one and come back
On Error GoTo bm_New_Worksheet
With Worksheets(wsn)
On Error GoTo bm_Safe_Exit
rVAL.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'when inserting rows, always work from the bottom to the top
For i = .Cells(Rows.Count, 3).End(xlUp).Row To 3 Step -1
If .Cells(i, 3).Value2 <> .Cells(i - 1, 3).Value2 Then
.Rows(i).Insert
End If
Next i
'autofit the columns
For i = .Columns.Count To 1 Step -1
.Columns(i).AutoFit
Next i
End With
End If
End With
Next p
End With
End With
GoTo bm_Safe_Exit
bm_New_Worksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = wsn
rHDR.Copy Destination:=.Cells(1, 1)
End With
Resume
bm_Safe_Exit:
End Sub
When a worksheet that is referenced by the wsn string does not exist, the On Error GoTo bm_New_Worksheet runs off and creates one. The Resume brings the code processing right back to the place it errored out.
One caution when using this method is to ensure that you have unique, legal worksheet names returned by your VLOOKUP function.
What I am trying to achieve is to copy the unique words (they repeat a few times) of sheet "Data" column A (ignoring header) to sheet "Country" column A and then add a second column to this sheet with the counting of occurrences of every word found. At same time ordering the list from higher to smaller. See the prints below as example.
Sheet "Data":
Sheet "Country" and the output i want to accomplish:
What I have so far, but not working (givin' error):
Sub Count_Sort()
Dim lastRow As Integer
Dim ws As String
Dim c As Range
ws = ActiveSheet.Name
lastRow = LastUsedRow
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$A$" & lastRow).RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Name = "Country"
Sheets(ws).Activate
Set c = Range("A1")
Set d = Sheets("Country").Range("A1")
Do While Not IsEmpty(c)
Do While Not IsEmpty(d)
If c.Value = d.Value Then
d.Offset(0, 1).Value = d.Offset(0, 1).Value + 1
Set d = d.Offset(1, 0)
Exit Do
End If
Set d = d.Offset(1, 0)
Loop
Set c = c.Offset(1, 0)
Set d = Sheets("Country").Range("A1")
Loop
End Sub
Public Function LastUsedRow()
LastUsedRow = [A65536].End(xlUp).Row
End Function
Any help would be most welcome...
Ps. I intend to do the same to all the columns of sheet "Data" (around 20), copy to a different sheet and then count and order each word. But if i manage to this in one, i think i will get to the others. Thanks again.
Keeping the general structure of your code:
Sub Count_Sort()
Dim i As Integer
Dim ws As Worksheet, cs As Worksheet
Set ws = Sheets("Data")
ws.Select
ws.Range("A2", ws.Range("A2").End(xlDown)).Select 'Update for different data column
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Country" 'Update for different data column
Set cs = Sheets("Country") 'Update for different data column
cs.Range("A2").Select
cs.Paste
Application.CutCopyMode = False
cs.Range("A2", cs.Range("A2").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
cs.Range("A1") = ws.Range("A1").Value 'Update for different data column (only ws.Range("A1").Value) (this is just the column heading)
cs.Range("B1") = "X times"
For i = 1 To cs.Range("A2", cs.Range("A2").End(xlDown).End(xlUp)).Rows.Count
cs.Cells(1 + i, 2) = Application.CountIf(ws.Range("A2", ws.Range("A2").End(xlDown)), cs.Cells(1 + i, 1)) 'Update for different data column
Next i
cs.Range(cs.Cells(2, 1), cs.Cells(cs.Range("A2").End(xlDown).Row, 2)).Sort Key1:=cs.Range("B1"), order1:=xlDescending, Header:=xlNo
End Sub
You can then just change the references for the different columns and/or worksheets.
Additionally, you should consider adding some error handling or checks to make sure your code doesn't crash if the sheet you are adding exists.
This is very easy to do without any VBA at all, using excel's built-in functions and techniques. However, since it seems you have many to do, I would like to suggest using VBA to utilize Excels existing tools to help you do the work faster (and with less code):
Also, it's best practice to avoid using .Select and .Active statements as much as possible.
Sub Count_Sort()
Dim lastRow As Integer
Dim ws As Worksheet, wsA As Worksheet
Set ws = Sheets("Data") 'ActiveSheet.Name ... better to use actual sheet name
Set wsA = Sheets.Add(After:=Sheets(Sheets.Count))
With ws
lastRow = LastUsedRow
.Range("B2:A" & lastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsA.Range("A1"), Unique:=True
End With
With wsA
.Name = "Country"
With .Range("B2")
.Formula = "=Countif(" & ws.Name & "!A:A,A2)"
.AutoFill wsA.Range("A1").End(xlDown).Offset(, 1)
End With
End With
End Sub
Public Function LastUsedRow()
LastUsedRow = [A65536].End(xlUp).Row
End Function