This program is intended to be used to copy data from a pivot table on another sheet (varying number of rows for each data set). Each set of pasted data is used to create its own waterfall chart, for which I have templates already made on a different sheet.
There are a couple of issues I am having with this code.
1) For some reason, it no longer runs (I refactored the code from a macro) and gives me the error 'Compile Error: Sub or Function not defined'
- I've tried making a new module and a new macro but to no avail
2) Also, I want to change the range that the chart graphs based on the size of the data set. Here's what I have currently hardcoded:
Selection.Formula = "=SERIES(,Sheet5!R8C1:R17C1,Sheet5!R8C4:R17C4,1)"
So, Sheet5!R8C1:R17C1 would need to become SheetN!Start:End
Complete Code below:
Sub WF_New_Sheet()
Dim copyFrom As Range
Dim wS As Worksheet 'use as current worksheet
Dim cht As Chart
'Paste and format data
Set wS = Sheets("Pivot 1")
copyFrom = wSRange("C82:D90")
Set wS = Sheets.Add(After:=Worksheets.Count)
wS.Range("A9").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Selection.Columns.AutoFit
Application.CutCopyMode = False
Range("A9", Range("B" & Rows.Count).End(xlUp).Address).sort Key1:=[b9], _
Order1:=xlAscending, Header:=xlNo 'sorts in 2 lines
Range("A8").Value = "Total"
Range("B8").Value = "=SUM(R[1]C:R[9]C)"
Dim rNum As Integer: rNum = Range("A9", Range("B" & Rows.Count).End(xlUp).Address).Rows.Count
'Paste data template and chart
copyFrom = Sheets("Sheet4").Range("D2:G15") 'sheet 4 is hardcoded and contains templates
wS.Range("D6").Resize(copyFrom.Rows.Count).Value = copyFrom.Value
Sheets("Sheet4").ChartObjects("Chart 1").Activate
Application.CutCopyMode = False
ActiveChart.ChartArea.Copy
wS.Range("I7").Select
ActiveSheet.Paste
ActiveSheet.ChartObjects("Chart 1").Activate
'Set appropriate ranges for chart data; format data for display
ActiveChart.SeriesCollection(2).Select
Selection.Formula = "=SERIES(,Sheet5!R8C1:R17C1,Sheet5!R8C5:R17C5,2)" 'How to make this dynamic?
ActiveChart.SeriesCollection(1).Select
Selection.Formula = "=SERIES(,Sheet5!R8C1:R17C1,Sheet5!R8C4:R17C4,1)" 'How to make this dynamic?
Range("B8").Value = "=SUM(R[1]C:R[9]C)*-1"
With Range("b9", "b17")
.Value = Evaluate(.Address & "*" & -1)
End With
End Sub
*edit code fixed to include sub and end sub
Figured out how to adjust the chart size. Added these lines:
Dim rowStart As Integer: rowStart = InputBox("Please enter starting row of your dataset.")
Dim rowEnd As Integer: rowEnd = InputBox("Please enter ending row of your dataset.")
Set copyFrom = Sheets("Pivot 1").Range(Sheets("Pivot 1").Cells(rowStart, colOne), Sheets("Pivot 1").Cells(rowEnd, colOne))
Set wS = Sheets.Add
wS.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
wS.Range("A9").Resize(copyFrom.Rows.Count, copyFrom.Columns.Count).Value = copyFrom.Value
Set copyFrom = Sheets("Pivot 1").Range(Sheets("Pivot 1").Cells(rowStart, colTwo), Sheets("Pivot 1").Cells(rowEnd, colTwo))
wS.Range("B9").Resize(copyFrom.Rows.Count, copyFrom.Columns.Count).Value = copyFrom.Value
Related
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 have had some answers to my question below, but despite numerous attempts I think my code is now just a total mess, and cannot fathom where it is wrong.
So I have a range A12:N112 that needs sorted on row A with descending values.
Next I need to copy each row (B:L) where column A has a "1" in it and paste it into the first blank row in another workbook, based on column D being blank. I then need to copy the number generated in column A for the row I have just pasted into, and then paste this back into the original row I copied in row N of the first spreadsheet.
I need this then to loop until we reach the first value of "0" in the first spreadsheet.
Here is my code, and although I can get the sort to work, I cannot get anything at all to copy or paste. This is similar to code i've used before for a single cut copy paste, but cannot get it to work at all here.
Dim r As Long
Dim lr As Long
Dim wkb As Workbook
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Set wkb = ThisWorkbook
Set ws = wkb.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srveurfcl03.nov.com\IS-GBR-GLBISETNRegister$\Serial No Trial\Serialisation Log.xlsx")
Set ws2 = wkb2.Worksheets("SNo Log")
wkb.Activate
ws.Activate
ActiveWorkbook.Worksheets("Data Entry").sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data Entry").sort.SortFields.Add Key:=Range( _
"A12:A112"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Data Entry").sort
.SetRange Range("A11:N112")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For r = 12 To lr
If wkb.ws.Cells(r, 1).Value = 1 Then
ws.Cells(r, "B:L").Copy
wkb2.Activate
ws2.Activate
Range("D" & Rows.Count).EndX(x1Up).Offset(1).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Range("A" & Rows.Count).End(xlUp).Offset(0).Select
Selection.Copy
wkb.Activate
ws.Cells(r, 13).Value.Paste
End If
If wkb.ws.Cells(r, 1).Value = 0 Then
ws.Cells(4, 9).Select
ActiveCell.FormulaR1C1 = "Serial No. Issue complete for this OA"
End If
Range("F5").Select
Next r
Any help would be greatly appreciated as it always is. I've tried to set variables, but cannot get them to work on bits of my code due to object errors so had to go back to the code I know works. But this only does for fixed ranges, which I will not have in this workbook.
Per my comments, you don't need to sort your data, or use Activate. Using Range("D" & Rows.Count).EndX(x1Up).Offset(1) was going in the right direction except you needed to remove the X in EndX. Also, the portion of code below does not make any sense. So you need to clarify what you want, to include an example of the outcome, if needed.
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Range("A" & Rows.Count).End(xlUp).Offset(0).Select
Selection.Copy
wkb.Activate
ws.Cells(r, 13).Value.Paste
End If
If wkb.ws.Cells(r, 1).Value = 0 Then
ws.Cells(4, 9).Select
ActiveCell.FormulaR1C1 = "Serial No. Issue complete for this OA"
End If
Range("F5").Select
The best way to copy a range is to copy the complete range, not line-by-line. The code below will hide any rows from Range("A12:A112") that do not have a "1" in column A. It will then copy the visible cells in the range using SpecialCells(xlCellTypeVisible) and paste to the first empty cell in ws2.Column(4). It then makes all the rows that were hidden visible again. This code will work if your workbook and worksheet variables are correct.
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Dim Rng As Range
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srveurfcl03.nov.com\IS-GBR-GLBISETNRegister$\Serial No Trial\Serialisation Log.xlsx")
Set ws2 = wkb2.Worksheets("SNo Log")
For Each cell In ws.Range("A12:A112")
If cell.Value <> "1" Then
cell.EntireRow.Hidden = True
End If
Next cell
Set Rng = ws.Range("A12:A112").SpecialCells(xlCellTypeVisible)
Rng.Copy Destination:=ws2.Cells(Rows.Count, 4).End(xlUp).Offset(1)
ws.Range("A12:A112").EntireRow.Hidden = False
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
I'm trying to copy a range of rows where the rows chosen are based on the value in one cell.I want to do this for all rows containing the same value in a cell, then move on to the next value an append to the bottom of the first list.
Below is my attempt at explaining what I wish to achieve - hopefully the above will help explain more my dilemma. I have looked around for this but not quite found what I want. I thought it would be simple and probably is.
I receive a data dump with thousands of rows of data and 18 columns. Based on the value of column P "Contract" I want to copy entire rows into a new single worksheet workingdata. Not all the data will go into the workingdata worksheet.
The contract numbers are c1234, c1235, c2345 etc.
What i am after achieving is copying and sorting, so copy all the rows of data where contract number is c1234, in workingdata, then directly below it copy all rows where contract is c1235 and so on.
I thought I could select the range P:P and sort but to no avail.
Sheets("Data Dump").Select
Columns("P:P").Select
If Selection.Value = "C1234" Then
Selection.EntireRow.copy
I know I should post what i have tried, but it would be a pathetic, for some reason I just can't seem to get my head round this one.
Here's my latest effort - I know there are errors
Dim oWorksheet As Excel.Worksheet
Dim oRangeSource As Excel.Range
Dim oRangeDest As Excel.Range
Set oWorksheet = Worksheets("DataDump")
Set oRangeSource = oWorksheet.Range("p:p")
Set oRangeDest = Worksheets("workingdata")
If oRangeSource="CA0004000" Then Select.EntireRow
Selection.EntireRow.copy
Sheets("workingdata").Select.Paste
End If
latest effort but does not sort data or get rid of unwanted, I have to do a manual filter and sort which sorts of defeats the object of the macro
Sub copy()
'
' copy Macro
'
Dim rngContracts As Range: Set rngContracts = Sheets("DataDump").Range("P:P")
Dim wsData As Worksheet
Dim wsFound As Boolean: wsFound = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Working Data" Then
Set wsData = ws
wsFound = True
Exit For
End If
Next ws
If wsFound = False Then
Application.CutCopyMode = False
ActiveSheet.Range("A1").EntireRow.copy
Set wsData = Sheets.Add(After:=Sheets(Sheets.Count))
wsData.Name = "Working Data"
wsData.Range("A1").EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Dim iCell As Range
For Each iCell In rngContracts
If iCell.EntireRow.Hidden = False Then
Application.CutCopyMode = False
iCell.EntireRow.copy
wsData.Range("P" & Rows.Count).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Next iCell
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Latest attaempt - copies the data I need but does not sort:
Sub copytest()
'
' copytest Macro
'
Set MR = Sheets("data Dump").Range("P:P")
For Each cell In MR
If cell.Value = "CA000154" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000220" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000393" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000429" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
Record a macro to set filters on your data select one filter only.
Then, edit the code and loop through each filter copying the visible range on to your sheet. This must also sort your data as the filters are already sorted.
Also, take a look at creating filter arrays in the Excel VBA help with regards to using them to sort.