I am filtering a large data set on the first sheet in my workbook and then I am creating a separate worksheet in the workbook for each unique name in the first column of the main data set.
After I filter the main data set for a given name, I am attempting to subtotal a particular filtered column (let's say column C), for example:
Sub CreateSheets()
Dim wsCurrent As Worksheet
Dim wsNew As Worksheet
Dim iLeft As Integer
Dim length As Long
Set wsCurrent = ActiveSheet
Application.ScreenUpdating = False
'Copy list of all players and remove duplicates
Range("A2", Range("A2").End(xlDown)).Copy Range("AY1")
Range("AY1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'Iterator
iLeft = Range("AY1").CurrentRegion.Rows.Count - 1
'For each player
Do While iLeft > 13
Set wsNew = Worksheets.Add
With wsCurrent.Range("A2").CurrentRegion
'Player name from copied list
.AutoFilter Field:=1, Criteria1:=wsCurrent.Range("AY1").Offset(iLeft).Value
'Hits
.AutoFilter Field:=3, Criteria1:="1"
length = .Range("C" & Rows.Count).End(xlUp).Row
wsNew.Range("A1") = "=SUBTOTAL(9," & wsCurrent.Name & "!C2:C" & length & ")"
'Turn off filters
'.AutoFilter
End With
'Name player sheet and move onto next
wsNew.Name = wsCurrent.Range("AY1").Offset(iLeft).Value
iLeft = iLeft - 1
Loop
'Clear player names in copied region
wsCurrent.Range("AY1").CurrentRegion.Clear
Application.ScreenUpdating = True
End Sub
The main issue here is that the subtotal function call no longer find the referenced cell on the main sheet. Any help is much appreciated.
EDIT:
The following now provides the correct subtotal.
length = .Range("C" & Rows.Count).End(xlUp).Row
wsNew.Range("A1") = "=SUBTOTAL(9," & wsCurrent.Name & "!C2:C" & length & ")"
wsNew.Range("A1").Value = wsNew.Range("A1").Value
The last line ensures that when the filter is removed, the original sum of the visible cells remains (instead of then taking the sum of the visible cells with the filter now removed).
Have you tried including the original sheet name as a reference in the Subtotal formula?
wsNew.Range("A1") = "=SUBTOTAL(9," & wsCurrent.Name & "!C2:C" & length & ")"
I replaced 9,C2:C with 9, " & wsCurrent.Name & "!C2:C which should reference it properly.
Related
I am not an expert on excel vba, but need to assistance with it.
I have an excel worksheet currently with two sheets
"Datas" sheet : All my long list of data (click to see) is here.
"Template" sheet. A template (click to see) i created to format my data
I know this is going to be bulky.
I need a macro, or button that
can create a new sheet based on the template above for each line in the Column A value in "Datas" sheet
the name of the new sheet will be taken from the Column A value in "Datas" sheet
The new sheet should retain the formatting of the template after data has been copied
In summary it should look somewhat like this
this (click to see) for the first line in column A of Datas sheet
and this (click to see) for the second line in column A of Datas Sheet.
Here is a sample of the worksheet uploaded on
https://ufile.io/bxwo6
I have infact tried the following
http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-sheets
PART 2 - Parse New Data To New Sheets (macro)
It did the job of taking each line and split it into different sheets. The results are
This is my Data sheet
This is the result of the split which is good
I am somehow stuck on how to make it adapt to my template formatting.
I would be grateful if you could provide any tip, help or suggestion that i can try
Many Thanks
UPDATE:
I have tried the following code. create a copy of the template and rename it according to the value in Column A from the source
Sub AutoAddSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Datas").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("TEMPLATE").Copy After:=Sheets(Sheets.Count) 'Create a new worksheet as a copy of Sheet number 9 in this example
Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets
Next MyCell
End Sub
UPDATE 2: This is the code that i modified from the link above. Note we cannot rename the sheets using column ":" value therefore, i modified my source by changing it from 1:1 into 1, 1:2 into 2
Option Explicit
Sub ParseItems()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long, Append As Boolean
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 1
'Sheet with data in it
Set ws = Sheets("Data")
'option to append new data below old data
If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & _
"(if no, new data will replace old data)", _
vbYesNo, "Append new Data?") = vbYes Then Append = True
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:Z1"
TitleRow = Range(vTitles).Cells(1).Row
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get a temporary list of unique values from vCol
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "key"
For Itm = TitleRow + 1 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
'Sort the temporary list
ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
'clear temporary list
ws.Columns(iCol).Clear
'Turn on the autofilter
ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then 'create sheet if needed
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
NR = 1
Else 'if it exists already
Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count) 'ordering the sheets
If Append Then 'find next empty row
NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
Else
Sheets(CStr(MyArr(Itm))).Cells.Clear 'clear data if not appending
NR = 1
End If
End If
If NR = 1 Then 'copy titles and data
ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
Else 'copy data only
ws.Range("A" & TitleRow + 1 & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
End If
ws.Range(vTitles).AutoFilter Field:=vCol 'reset the autofilter
If Append And NR > 1 Then NR = NR - 1
MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count).End(xlUp).Row - NR
Sheets(CStr(MyArr(Itm))).Columns.AutoFit
Next Itm
'Cleanup
ws.Activate
ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
& MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub
This should give you an idea which you can start with. It loops through the datas and for each data row it copies the template, renames it and fills in the data row into specific ranges.
Option Explicit
Public Sub AutoParseItems()
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Datas")
Dim lRow As Long
lRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row 'find last row in column A
Const fRow As Long = 1 'set first data row
Dim iRow As Long
For iRow = fRow To lRow 'loop throug data rows
'create a copy of the sheet
ThisWorkbook.Worksheets("TEMPLATE").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Dim wsNewTemplateCopy As Worksheet
Set wsNewTemplateCopy = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'determine new sheet name and rename the sheet
With wsData.Cells(iRow, "A")
wsNewTemplateCopy.Name = Right$(.Text, Len(.Text) - InStr(1, .Text, ":")) 'find : to determine new sheet name
End With
'fill in the text into the new sheet
wsNewTemplateCopy.Range("A1").Value = wsData.Cells(iRow, "A").Value
wsNewTemplateCopy.Range("A5").Value = wsData.Cells(iRow, "C").Value
wsNewTemplateCopy.Range("A22").Value = wsData.Cells(iRow, "D").Value
'modify the ranges where you need your data
Next iRow
End Sub
I'm new here and to vba in general. I basically just read myself into the matter for my new job. So please bear with me.
I'm looking for a solution to my issue and found seperate solutions for parts but I'm not able to piece them together.
My goal is the following:
Copy 3 Worksheets of a workbook to a new one (not existing yet) and save it under the current date with a specific name.
Here's the code that I put together so far for that which works fine.
Sub export()
Dim path As String
Dim file As String
Dim ws As Worksheet
Dim rng As Range
path = "D:\#Inbox\"
file = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "accr " & Format(DateSerial(Year(Date), Month(Date), 1), "YYYY_MM") & " city" & ".xlsx"
Application.ScreenUpdating = False
Sheets(Array("Accr", "Pivot", "Segments")).Select
Sheets(Array("Accr", "Pivot", "Segments")).Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
For Each ws In Worksheets
ws.Rectangles.Delete
Next
Sheets(Array("Pivot", "Segments")).Visible = False
ActiveWorkbook.SaveAs Filename:=path & file, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Sheets("Menu =>").Select
Range("C1").Select
End Sub
1st condition: the new workbook should not be created manually and opened first, but the macro should do that.
2nd condition: the 1st workbook should have autofilters selected and then only visible cells copied. Is that possible as a whole worksheet, or do I have to copy the cells and create a worksheet in the new workbook?
Here's the code for the filter
Sheets("Accr").Select
Reset_Filter
Selection.AutoFilter Field:=1, Criteria1:="12"
Selection.AutoFilter Field:=2, Criteria1:="booked"
Selection.AutoFilter Field:=35, Criteria1:="Frankfurt"
Set rng = Application.Intersect(ActiveSheet.UsedRange)
rng.SpecialCells(xlCellTypeVisible).Copy
3rd condition: the other two worksheets should be copied without formulas but with format. (That is included in the first code sample)
My problem is now, to piece everything together so that there are 3 worksheets in the new workbook containing in the first ws the visible cells of the source ws with the autofilter and the other two worksheets containing only the data and the format and being hidden.
Info to my reasoning: the first worksheet refers with the formulas to the other two worksheets so that the recipients of the file have preselected fields and lists to fill out the cells.
Thank you very much in advance.
EDIT: Background Info:
The Accr sheet contains accrual informattion and has the Month information in column A. Since several years should be also able to be compared in one Pivot Table later on, the format was changed from a mere number to a date (format: MM.YYYY).
Edit
Alright, here is a different code, this copies the worksheets then removes the rows in Accr which do not meet the criteria. Be sure to make ranges absolute, put $ in front of the column and row in a formula, the vlookup you mentioned should become =VLOOKUP(R2097;Segments!$G:$Q;11;0) and this goes for any formula on the Accr sheet that references a fixed range anywhere.
Sub Export()
Dim NewWorkbook As Workbook
Dim Ws As Worksheet
Dim fPath As String, fName As String
Dim i As Long
Dim RowsToDelete As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set NewWorkbook = Workbooks.Add
fPath = "D:\#Inbox\"
fName = VBA.Format(VBA.Date, "YYYY-MM-DD") & " " & VBA.Format(VBA.Time, "hhmm") & " " & "accr " & VBA.Format(VBA.DateSerial(VBA.Year(VBA.Date), VBA.Month(VBA.Date), 1), "YYYY_MM") & " city"
NewWorkbook.SaveAs fPath & fName, xlOpenXMLWorkbook
ThisWorkbook.Worksheets(Array("Accr", "Pivot", "Segments")).Copy NewWorkbook.Worksheets(1)
For Each Ws In NewWorkbook.Worksheets
With Ws
If Not .Name = "Accr" And Not .Name = "Pivot" And Not .Name = "Segments" Then
.Delete
ElseIf Ws.Name = "Accr" Then
For i = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not .Cells(i, 1) = .Cells(i, 1) = Month(ThisWorkbook.Worksheets("Mon").Cells(19, 2)) And Not .Cells(i, 2) = "booked" And Not .Cells(i, 35) = "Frankfurt" Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Rows(i).EntireRow
Else
Set RowsToDelete = Union(RowsToDelete, .Rows(i).EntireRow)
End If
End If
Next i
If Not RowsToDelete Is Nothing Then
RowsToDelete.Delete xlUp
End If
ElseIf .Name = "Pivot" Or .Name = "Segments" Then
.Visible = xlSheetHidden
.UsedRange = Ws.UsedRange.Value
End If
End With
Next Ws
NewWorkbook.Save
NewWorkbook.Close
Application.Goto ThisWorkbook.Worksheets("Menu =>").Cells(1, 3)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
End of edit
Ok... so after fiddling around with it a while and collecting several pieces of information around this website, I finally have a solution.
The main problem, was the first criteria, which is a date field. I found out that vba has its problems when the date is not in US-Format. So I made a workaround and made a textformat date in my parameter worksheet, so that I always have the export of the sheets for the current month set in the workbook.
In my accruals-data I just had to change the format in column A to have text (e.g. '01.2016).
Plus I optimized my rawdata a little bit, so that I only have to export one additional worksheet, which will be hidden and contains only hardcopy values, so that there is no external link to my original file anymore.
Sub ACTION_Export_AbgrBerlin()
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
Dim oRow As Range, rng As Range
Dim myrows As Range
' define filepath and filename
Pfad = "D:\#Inbox\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "Abr " _
& Format(DateSerial(Year(Date), Month(Date), 1), "yyyy-mm") & " Berlin" & ".xlsx"
Application.ScreenUpdating = False
Sheets(Array("Abgr", "Masterdata MP")).Copy
' hardcopy of values
Sheets("Masterdata MP").UsedRange = Sheets("Masterdata MP").UsedRange.Value
' delete Macrobuttons and Hyperlinks
For Each ws In Worksheets
ws.Rectangles.Delete
ws.Hyperlinks.Delete
Next
' delete first 3 rows (that are placeholders for the macrobuttons in the original file)
With Sheets("Abgr")
.AutoFilterMode = False
.Rows("1:3").EntireRow.Delete
' set Autofilter matching the following criteria
.Range("A1:AO1048576").AutoFilter
'refer to parameter worksheet which contains the current date as textformat
.Range("A1:AO1048576").AutoFilter Field:=1, Criteria1:=ThisWorkbook.Worksheets("Mon").Range("E21")
.Range("A1:AO1048576").AutoFilter Field:=2, Criteria1:=Array(1, "gebucht")
.Range("A1:AO1048576").AutoFilter Field:=36, Criteria1:=Array(1, "Abgr Berlin")
End With
'delete hidden rows i.e. delete anything but the selection
With Sheets("Abgr")
Set myrows = Intersect(.Range("A:A").EntireRow, .UsedRange)
End With
For Each oRow In myrows.Columns(1).Cells
If oRow.EntireRow.Hidden Then
If rng Is Nothing Then
Set rng = oRow
Else
Set rng = Union(rng, oRow)
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
Sheets("Masterdata MP").Visible = xlSheetHidden
Sheets("Masterdata MP").UsedRange = Sheets("Masterdata MP").UsedRange.Value
ActiveWorkbook.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
'go back to main menu in original workbook
Sheets("Menu").Select
End Sub
Now I can create one sub for each file I have to create and then run all the subs after each other. That saves me a bunch of time.
The part with the hidden rows, I found here Delete Hidden/Invisible Rows after Autofilter Excel VBA
Thanks again #silentrevolution for your help, it gave me the pointers to get the needed result.
It's not the cleanest code and I'm sure that it can be made a bit leaner, so I would appreciate any recommendations. But for now it serves my needs.
Newbee here to both this site and Excel VBA. I used RichA's code in the below post and was able to make it work well for my purpose of populating/copying data in on sheet (Sheet2) from another sheet.
CODE LINK TO ORIGINAL POST
Excel VBA Copy and Paste Loop within Loop
I have a question on how to limit the range to a 'named range' (C13:Z111) rather than the 'entire column' ("C") in this code. I cannot seem to get it to limit to copy rows, starting with last row with data and counting down to the first row.
I have some rows (C1:C12) with titles at the top and the data starts at row 13. So when copying values from one sheet to the 'other' sheet, the top rows also copy. I would like to end the copying of data at row 13.
Thank you for your help.
Here is what currently works with the exception that I am not able to limit the range.
Sub Generate_Invoice()
Dim i As Long
Dim ii As Long
Dim i3 As Long
Dim LastRow As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("INCENTIVE")
Set sht2 = wb.Sheets("Sheet2")
Sheets("Sheet2").Select
Range("B11:Z200").ClearContents
'Find the last row (in column C) with data.
LastRow = sht1.Range("C13:C111").Find("*", searchdirection:=xlPrevious).Row
ii = 2
'This is the beginning of the loop >>>This Works BUT BUT BUT goes all the way to the top - REQUESTING HELP WITH CODE ENDS AT ROW 13 AND DOES NOT GO PAST<<<
For i = 3 To LastRow
'First activity
sht2.Range("B" & ii) = sht1.Range("C" & i).Value
sht2.Range("C" & ii) = sht1.Range("G" & i).Value
sht2.Range("D" & ii) = sht1.Range("H" & i).Value
sht2.Range("E" & ii) = sht1.Range("P" & i).Value
sht2.Range("F" & ii) = sht1.Range("R" & i).Value
sht2.Range("G" & ii) = sht1.Range("AD" & i).Value
ii = ii + 1
Next i
'Return to "Sheet2"
Sheets("Sheet2").Select
'Add SUM at bottom of last record in Range"D"
Dim ws As Worksheet
For Each ws In Worksheets
With ws.Range("F" & Rows.Count).End(xlUp).Offset(2)
.FormulaR1C1 = "=SUM(R11C6:R[-1]C6)"
.Offset(, -1).Value = "Total:"
End With
Next ws
End Sub
You were looking for the last row but only looking within the populated area. I would suggest changing the method that the last row is determined by starting at the bottom of the worksheet and finding the last populated cell in column C. This would be like being in C1048576 and tapping Ctrl+▲.
'Find the last row (in column C) with data.
LastRow = sht1.Cells(Rows.Count, "C").End(xlUp).Row
'not sure whether you want to reverse this as well
ii = 2
'This is the beginning of the loop >>>This Works BUT BUT BUT goes all the way to the top - REQUESTING HELP WITH CODE ENDS AT ROW 13 AND DOES NOT GO PAST<<<
For i = LastRow To 13 Step -1 'work from the bottom to the top.
'First activity
sht2.Range("B" & ii) = sht1.Range("C" & i).Value
sht2.Range("C" & ii) = sht1.Range("G" & i).Value
sht2.Range("D" & ii) = sht1.Range("H" & i).Value
sht2.Range("E" & ii) = sht1.Range("P" & i).Value
sht2.Range("F" & ii) = sht1.Range("R" & i).Value
sht2.Range("G" & ii) = sht1.Range("AD" & i).Value
'not sure whether you want to reverse this as well
ii = ii + 1
Next i
You just need to exit the for loop based on whatever your desired criteria is. For example:
If ii = 13 Then Exit For
I have the following macro (part of it is copied). I want to move data from the Limas sheet to the Constanta sheet. The Constanta sheet already contains some information. By running the macro, this information disappears.
How do I change the code so that the information from the Limas sheet is copied to the Constanta sheet on the first blank row?
Sub Limas()
Dim LSheetMain, LSheet1, LSheet2, LSheet3, LSheet4 As String
Dim LSheet5, LSheet6 As String
Dim LContinue As Boolean
Dim LFirstRow, LRow As Integer
Dim LCurCORow, LCurRRow, LCurRERow, LCurPRow, LCurBRow As Integer
'Set up names of sheets
LSheetMain = "Limas"
LSheet1 = "Constanta"
LSheet2 = "Rastolita"
LSheet3 = "Reghin"
LSheet4 = "Poliesti"
LSheet5 = "Bucharest"
LSheet6 = "Curtiu"
'Initialize variables
LContinue = True
LFirstRow = 2
LRow = LFirstRow
LCurCORow = 2
LCurRRow = 2
LCurRERow = 2
LCurPRow = 2
LCurBRow = 2
LCurCuRow = 2
Sheets(LSheetMain).Select
'Loop through all column I values until a blank cell is found
While LContinue = True
'Found a blank cell, do not continue
If Len(Range("A" & CStr(LRow)).Value) = 0 Then
LContinue = False
'Copy and format data
Else
'--- "Constanta" ---
If Range("I" & CStr(LRow)).Value = "Constanta" Then
'Copy values from columns A, B, C, and H from "Limas" sheet
Range("A" & CStr(LRow) & ",B" & CStr(LRow) & ",C" & _
CStr(LRow) & ",H" & CStr(LRow)).Select
Selection.copy
'Paste onto "Constanta" sheet
Sheets(LSheet1).Select
Range("A" & CStr(LCurCORow)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
'Increment row counter on "Constanta" sheet
LCurCORow = LCurCORow + 1
'Go back to "Limas" sheet and continue where left off
Sheets(LSheetMain).Select
End If
Declaring variables in this manner means that only the last one on each line is declared as a string; all of the others are declared as variant types.
Dim LSheetMain, LSheet1, LSheet2, LSheet3, LSheet4 As String
Dim LSheet5, LSheet6 As String
Should be:
Dim LSheetMain As String, LSheet1 As String, LSheet2 As String, LSheet3 As String
Dim LSheet4 As String, LSheet5 As String, LSheet6 As String
As to your problem moving the data, rather than loop through the rows looking for Constanta (or one of the other worksheet names) in column I, filter on column I and copy the visible cells to the appropriate worksheet. Since we only got a portion of your code, I'll assume that you wanted to loop through each of the worksheets, copying from the Limas worksheet to the worksheet named the same as your filter.
Sub Limas()
Dim lr As Long, v As Long, vSheets As Variant
vSheets = Array("Limas", "Constanta", "Rastolita", "Reghin", "Poliesti", "Bucharest", "Curtiu")
With Sheets(vSheets(0)).Cells(1, 1).CurrentRegion
lr = .Rows.Count
For v = 1 To UBound(vSheets)
.AutoFilter
.AutoFilter Field:=9, Criteria1:="=" & vSheets(v), Operator:=xlAnd
If CBool(Application.Subtotal(103, .Columns(9).Offset(1, 0))) Then
.Range("A2:C" & lr & ",H2:H" & lr).Copy _
Destination:=Sheets(vSheets(v)).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
' remove commenting to activate deleting the rows after the copy
'.Offset(1, 0).EntireRow.Delete
End If
.AutoFilter
Next v
End With
End Sub
I've commented out the line that removed the rows from the Limas worksheet after copying. After you have tested this, you can uncomment that line. This code snippet assumes that all of those worksheets exist in the workbook.
I am trying to use a macro to clean up data files and only copy on Sheet2 what is most relevant.
I have written the code to find the row I want the data to be copied from. However I can only copy the row itself and not the range underneath. Please note I need the range to go from that row to the last column and last row as the size of the matriz always varies.
s N s N s N s N s rpm
Linear Real Linear Real Linear Real Linear Real Linear Amplitude
0.0000030 9853.66 0.0000030 5951.83 0.0000030 533.48 0.0000030 476.15 0.0000030 2150.16
0.0000226 9848.63 0.0000226 5948.19 0.0000226 557.02 0.0000226 488.60 0.0000226 2150.16
0.0000421 9826.05 0.0000421 5956.22 0.0000421 615.94 0.0000421 480.75 0.0000421 2150.15
0.0000616 9829.72 0.0000616 5989.72 0.0000616 642.59 0.0000616 476.77 0.0000616 2150.15
So basically the code below finds that first row and copies it in Sheet2. I need the macro to also select the range underneath and copy it onto Sheet2. Please can you help me finishing off the script?
Sub SearchForRawData()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 1
LSearchRow = 1
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
While Len(Range("A" & CStr(LSearchRow)).Value) >= 0
'If value in column A = "s", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = "s" Then
'Select row and range in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Select all Raw Data underneath found Row to Copy
'Paste all Raw Data into Sheet 2
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A1
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error has occured"
End Sub
You don't need a loop for this if you want to copy the row that has the "s" and everything below it to the target sheet. The following sub finds the row with the "s" in column A and then copies that row and everything below it to the target sheet.
Note that you should always avoid selecting or activating anything in VBA code, and that the normal way to copy and paste relies on selecting. If you use the syntax I've included here, the clipboard is not used and the target sheet does not need to be selected.
Sub CopyRowAndBelowToTarget()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim match As Range
Set wb = ThisWorkbook
Set src = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
Dim lastCopyRow As Long
Dim lastPasteRow As Long
Dim lastCol As Long
Dim matchRow As Long
Dim findMe As String
' specify what we're searching for
findMe = "s"
' find our search string in column A (1)
Set match = src.Columns(1).Find(What:=findMe, After:=src.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
' figure out what row our search string is on
matchRow = match.Row
' get the last row and column with data so we know how much to copy
lastCopyRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
' find out where on our target sheet we should paste the results
lastPasteRow = tgt.Range("A" & src.Rows.Count).End(xlUp).Row
' use copy/paste syntax that doesn't use the clipboard
' and doesn't select or activate
src.Range(Cells(matchRow, 1), Cells(lastCopyRow, lastCol)).Copy _
tgt.Range("A" & lastPasteRow)
End Sub
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
So firstly you don't acutally need the CStr, vba will cast numbers to strings by itself, i.e. Range(LSearchRow & ":" & LSearchRow) should work fine.
To find how many rows down to go use the end function of the range object:
bottomRow = Range("A" & LSearchRow).End(xldown).Row
Do the same for the column
lastCol = Range("A" & LSearchRow).End(xlleft).column
Now to copy:
Range("A" & LSearchRow & ":" & lastCol & bottomRow).Copy
However if you have empty cells inthe middleof the data then instead of using End(xldown), start at the bottom of the sheet and look up:
bottomRow = Range("A1000000").End(xlup).Row
etc