I've never used VBA before, I don't know the commands and stuff. I really trying and I need some help please. I've to copy only the visible data from specified columns and paste to another worksheet, but I receive Subscript out of range error, while running the code. In the code I've to select the rows from the 7th row and I think I coded this a bit rough. Can anyone check my code why is this not working? Any suggestions for a better solution is appreciated.
Sub CopyData()
Windows("Source.xlsx").Activate
Range("D7, F7, G7, I7, J7, K7, L7, M7, O7, AD7, AX7, CO7, CQ7, CR7, AX7").Select
Range(Selection, Selection.End(xlDown)).Select
If Selection.EntireColumn.Hidden = False Then
Selection.Copy
End If
Windows("Destination.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
End Sub
Give this a shot:
Sub CopyData()
'set variables for wkb and ws to copy
Dim wbSource As Workbook
Set wbSource = Workbooks("Source.xlsx")
Dim wsCopy As Worksheet
Set wsCopy = wbSource.Worksheets("Sheet1") 'change name as needed
'set variables for wkb and ws to paste
Dim wbDest As Workbook
Set wbDest = Workbooks("Destination.xlsx")
Dim wsDest As Worksheet
Set wsDest = wbDest.Worksheets("Sheet1")
'copy visible cells for specific range
With wsCopy
Dim lRow As Long
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
Dim rCopy As Range
Set rCopy = Union(.Range("D7:D" & lRow), .Range("F7:F" & lRow), _
.Range("G7:G" & lRow), .Range("I7:I" & lRow), .Range("J7:J" & lRow), _
.Range("K7:K" & lRow), .Range("L7:L" & lRow), .Range("M7:M" & lRow), _
.Range("O7:O" & lRow), .Range("AD7:AD" & lRow), .Range("AX7:AX" & lRow), _
.Range("CO7:CO" & lRow), .Range("CQ7:CQ" & lRow), .Range("CR7:CR" & lRow))
End With
'paste
rCopy.SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A2")
End Sub
Dim rng As Range
Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("A1:H500"))'range depends your work
Windows("Destination.xlsx").Activate
rng.SpecialCells(xlCellTypeVisible).Copy Destination:=Range("A2")
or you just use,
ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
without intersection method. Totally depends on your work.
Related
I have two worksheets in the same workbook where they have different # of columns containing policy information and I would like to use vba to save multiple workbooks based on a certain column (state) since trying to save 50 times manually isn't the most efficient way.
State in sheet1 is column E & in sheet2 is column F. Now sheet1 & sheet2 have different ranges & columns so last row may need to be defined separately.
I found some codes online but wasn't able to make it work. My issues now is how to incorporate sheet2 and secondly make it work. The codes I have now have script out of range error in line Windows(state).Activate
Sub ExtractToNewWorkbook()
Dim ws As Worksheet
Dim wsNew As Workbook
Dim rData As Range
Dim rfl As Range
Dim state As String
Dim sfilename As String
Dim LR1 As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
LR1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
'Apply advance filter in your sheet
With ws
Set rData = Range("A1", "E" & LR1)
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state = rfl.Text
Set wsNew = Workbooks.Add
sfilename = state & ".xlsx"
'Set the Location
ActiveWorkbook.SaveAs FilePath & sfilename
Application.DisplayAlerts = False
ws.Activate
rData.AutoFilter Field:=5, Criteria1:=state
rData.Copy
Windows(state).Activate
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next rfl
Application.DisplayAlerts = True
End With
ws.Columns(Columns.Count).ClearContents
rData.AutoFilter
End Sub
You should avoid ActiveWorkbook and .Activate (also see: How to avoid using Select in Excel VBA). Instead access the workbook wsNew directly:
Set wsNew = Workbooks.Add
sfilename = state & ".xlsx"
'Set the Location
wsNew.SaveAs FilePath & sfilename
Application.DisplayAlerts = False
rData.AutoFilter Field:=5, Criteria1:=state
rData.Copy
wsNew.Worksheets(1).Paste
wsNew.Close SaveChanges:=True
Note that in Set rData = Range("A1", "E" & LR1) you missed a . before the range to make it use the with statement: Set rData = .Range("A1", "E" & LR1)
Note that you should consider to rename wsNew into wbNew in your entire procedure because you set a workbook with Set wsNew = Workbooks.Add and not a worksheet.
I am a military recruiter and am trying to use autofilter to filter out a range from another range. I got this from another stackoverflow page but can not figure out how to change that string strSearch to a range like 123#gmail, 234#gmail, 345#gmail, etc.
We get lists of leads but I'd like to keep the running list of opt-outs and have VBA double check and delete any cells that have a value from the opt-out worksheet. I am pretty new to VBA but really enjoy it. Thank you!
I'd like it to be strSearch = Sheets("Opt-Outs").Range("A:A") so that it takes all values in A:A and uses them as an autofilter. I believe it needs to be a string array but am lost as how to get there. Please help.
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub
This should do it...
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
Dim v() As Variant
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
v = Application.Transpose(Sheets("Opt-Outs").Range("A:A"))
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:=v
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As Variant
Dim i As Integer
i = 1
Sheets("Opt-Outs").Select
Range("H2").Value = "Ready"
Range("A2").Select
Do While Range("H2").Value <> Empty
Sheets("Opt-Outs").Select
Range("A2").Select
Cells(i + 1, 1).Copy
i = i + 1
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Range("H2").Value = IsBlank Then
Sheets("Email Addresses").Select
Exit Sub
Else
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("H2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End If
Loop
Anyone,
I'm trying to make a program in excel vba in which the macro would look/loop for the sheet name in the workbook base on the excel range. Also, after looking for the sheet name, the program would save the sheet based on the given file name on the other cell range.
My main problem here is on how I can save the loop file/sheet name based on the teritory name given in the picture provided below.
Hope you can help me with my problem.
Here's my recent work on the macro, I can save the file but it saves the file based on the sheet name I have looked up. Thanks.
sample picture here
Sub Save_Test()
Dim ws As Worksheet
Dim wb As Workbook
Dim c, b As Range
Dim rng, rng2 As Range
Dim mysheet As Worksheet
Dim LastRow, LastRow2 As Integer
Dim file_name As String
LastRow = Range("I" & rows.Count).End(xlUp).row
Set rng = Range("J5:J" & LastRow)
Set ws = Worksheets("Control")
For Each c In rng
Sheets(c.Value).Select
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Application.DisplayAlerts = False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Name = c.Value
Application.CutCopyMode = False
ActiveWindow.DisplayGridlines = False
TemplateLocation = ThisWorkbook.Path
file_name = c.Value
ActiveWorkbook.SaveAs Filename:=TemplateLocation & "\" & "Reports" & "\" & Format(Now() - 1, "mmyy") & " " & file_name & " Hustle Board thru " & Format(Now() - 1, "mm-dd-yy"), FileFormat:=51, CreateBackup:=False
Application.DisplayAlerts = False
ActiveWindow.Close
Next
Sheets("Control").Select
End Sub
You will have to fill in the other stuff you need to do, but going off your picture and you code, this should get you the value in the teritory column
Dim r As Range
Dim rng As Range
Dim LastRow As Long
Dim ws As Worksheet
LastRow = Range("I" & Rows.Count).End(xlUp).Row
Set rng = Range("J5:J" & LastRow)
For Each r In rng
file_name = r.Offset(, -1)
ActiveWorkbook.SaveAs Filename:=TemplateLocation & "\" & "Reports" & "\" & Format(Now() - 1, "mmyy") & " " & file_name & " Hustle Board thru " & Format(Now() - 1, "mm-dd-yy"), FileFormat:=51, CreateBackup:=False
Next r
End Sub
BTW, if you did not already know, declaring varibales like this below is not good practice.
Dim rng, rng2 As Range
In this case rng is not a rng at this point. You need to do this below to explicitly declare as a Range variable.
Dim rng as Range, rng2 As Range
I have the below code, which works fine but it is copying the formulas and cell formatting not just the values. could anyone tell me how to obtain just the values?
Option Explicit
Sub MoveQuick()
Dim sh As Worksheet
Dim ws As Worksheet
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
ws.[a2:o2000].ClearContents
sh.Range("B8", sh.Range("S" & Rows.Count).End(xlUp)).AutoFilter 1, "MTU"
sh.Range("D9", sh.Range("I" & Rows.Count).End(xlUp)).Copy ws.Range("A" & Rows.Count).End(xlUp)(2)
sh.Range("T9", sh.Range("V" & Rows.Count).End(xlUp)).Copy ws.Range("H" & Rows.Count).End(xlUp)(2)
sh.[B8].AutoFilter
End Sub
This code will work for you.
sh.Range("D9", sh.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
ws.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
I have two sheets containing the employee records.
Sheet1 contains the Event Date, CardNo, Employee Name, Dept Id, Employee No, Entry and Exit Time, Total Working Hours, Status, ConcatinatedColumn and Remarks (copied through vlookup from sheet2)
Sheet2 contains ConcatinatedColumn, Event Date, Employee No, Name, Remarks.
If the data in the remarks column of sheet2 is "Sick Off" then that row should be inserted to sheet1 without effecting the previous records.
I've already written the code for it but it does not work.
Would be really grateful if anyone can help me out !
THANKS IN ADVANCE !
MY CODE :
Sub SickOff()
Dim objWorksheet As Sheet2
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Sheet1
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Worksheets("Sheet2")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("G2:G" & objWorksheet.Cells(Rows.Count, "G").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells
objWorksheet.Select
If rngCell.Value = "Sick Off" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
Let's say you have data in Sheet2 as shown below
Let's say the end of data in Sheet1 looks like this
Logic:
We are using autofilter to get the relevant range in Sheet2 which match Sick Off in Col G. Once we get that, we copy the data to the last row in Sheet1. After the data is copied, we simply shuffle data across to match the column headers. As you mentioned that the headers won't change so we can take the liberty of hardcoding the column names for shuffling this data.
Code:
Paste this code in a module
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long, wsOlRow As Long, OutputRow As Long
Dim copyfrom As Range
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> This is the row where the data will be written
OutputRow = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row + 1
With wsO
wsOlRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter G on "Sick Off"
With .Range("G1:G" & wsOlRow)
.AutoFilter Field:=1, Criteria1:="=Sick Off"
Set copyfrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
If Not copyfrom Is Nothing Then
copyfrom.Copy wsI.Rows(OutputRow)
'~~> Shuffle data
With wsI
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & OutputRow & ":A" & lRow).Delete Shift:=xlToLeft
.Range("F" & OutputRow & ":F" & lRow).Copy .Range("K" & OutputRow)
.Range("F" & OutputRow & ":F" & lRow).ClearContents
.Range("B" & OutputRow & ":B" & lRow).Copy .Range("E" & OutputRow)
.Range("B" & OutputRow & ":B" & lRow).ClearContents
End With
End If
End Sub
Output: