Developing a code through which user selects a range in the active workbook. For the range selected i.e. A8:A12 i want to run a loop through which for each range in the selected range, the loop takes its value, Filters GL_Sheet's Current Region (GL_Rng) using that value and copy's the visible cells
The code is
'Declaring Workbooks
Dim GL_CY As Variant
Dim GL_Book As Workbook, Tgt_Book As Workbook
GL_CY = Application.GetOpenFilename(Title:="Open GL", FileFilter:="Excel Files (*.xls*),*xls*")
Set GL_Book = Application.Workbooks.Open(GL_CY)
Set Tgt_Book = Workbooks.Add
'Selecting Range
Dim GL_Code As Variant, GL_LR As Long, GL_Rng As range, Rng As range
Dim GL_Sheet As Worksheet, tgt As Worksheet
Set GL_Sheet = GL_Book.Worksheets(1)
GL_LR = GL_Sheet.range("B" & Rows.Count).End(xlUp).Row
Set GL_Rng = GL_Sheet.range("A4:R" & GL_LR).CurrentRegion.Offset(3, 0)
GL_Code = Application.InputBox(Prompt:="Select the range of GL codes to generate its GL activity ", Title:="Generate GL Activity", Type:=8)
' GL_Sheet.range("A3:A5").Value = range(GL_Code).Value
For Each Rng In range(GL_Code)
Set tgt = Tgt_Book.Worksheets.Add
GL_Rng.AutoFilter Field:=6, Criteria1:=GL_Code
GL_Rng.SpecialCells(xlCellTypeVisible).Copy
tgt.Paste
tgt.range("A1").CurrentRegion.Cut tgt.range("B6")
tgt.Cells.WrapText = False
tgt.Cells.Columns.AutoFit
tgt.Name = GL_Code
Application.CutCopyMode = False
Next Rng
As you can see I am struggling with the last part of the code which results in Error 1004 (Method of range...)
Naqi,
I created a little test routine to check out what was being returned from the InputBox.
Turns it was coming back as a Variant. I tried setting it as a Range but that wouldn't work either. However changing the Type:=2 (string) makes it work
Option Explicit
Sub Test()
Dim GL_Code As String
GL_Code = Application.InputBox(Prompt:="Select the range of GL codes to generate its GL activity ", _
Title:="Generate GL Activity", _
Type:=2)
Debug.Print Range(GL_Code).Address()
End Sub
'So by changing your Type to 2 the For Each rng statement should no longer create a problem.
Edit: Found an option using Type 8:
[Click here for the post I found this in.][1]
Sub MyMacro()
Dim GL_Code As Range
Set GL_Code = Application.InputBox("Select a range", "Get Range", Type:=8)
Debug.Print GL_Code.Address()
End Sub
'Since GL_Code is now a range your For Each should NOT enclose it in a Range() function!
HTH
Related
Hi I have created macro where it opens the sheet based on user input,
what I need is once the new sheet is opened I have some fields where user need to fill those data(Different subjects marks) and calculate the percentage using formula then I need to fill those data to another sheet named "Data" without overwriting previous data?.
Please suggest how to add data without overwriting in vba.
Sub open_sheet()
Dim sourcesheet As Worksheet
Dim ClassA As Worksheet
Dim ClassB As Worksheet
Dim ClassC As Worksheet
Set sourcesheet = Sheets("Main")
Set ClassA = Sheets("Class A")
Set ClassB = Sheets("Class B")
Set ClassC = Sheets("Class C")
If sourcesheet.Range("Class").Value = "Class A" Then
Worksheets("Class A").Activate
ElseIf sourcesheet.Range("Class").Value = "Class B" Then
Worksheets("Class B").Activate
Else:
Worksheets("Class C").Activate
End If
End Sub
Copy Cell Values to Another Worksheet
Option Explicit
Sub CopyData()
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Sheets("Main")
' Reference the source range (the values from these cells will be copied).
Dim srg As Range: Set srg = sws.Range("A3,B4,C5")
' Retrieve the destination worksheet name.
' Hopefully you have created a drop down to easily select the class.
Dim dName As String: dName = sws.Range("Class").Value
' Late at night (tired), a final check could become a life saver:
Dim Msg As Long
Msg = MsgBox("This will copy to """ & dName & """." & vbLf & vbLf _
& "Are you sure?", vbQuestion + vbYesNo)
If Msg = vbNo Then Exit Sub
' Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Sheets(dName)
If dws.FilterMode Then dws.ShowAllData ' 'Find' will fail if 'dws' filtered
' Reference the first (available) destination cell.
Dim dCell As Range ' First Destination Cell
With dws.UsedRange
Dim dlCell As Range ' Last Cell
Set dlCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then Exit Sub ' empty worksheet
Set dCell = dws.Cells(dlCell.Row + 1, "A") ' below last in column 'A'
End With
' Copy the values from the source to the destination cells.
Dim sCell As Range
For Each sCell In srg.Cells
dCell.Value = sCell.Value
Set dCell = dCell.Offset(, 1) ' next, adjacent to the right
Next sCell
MsgBox "Data copied.", vbInformation
End Sub
In general, here's a way to append info to a table. I would just put your average calculations in the table total row.
Option Explicit
Sub FillNewRow1()
Dim Class_A As Worksheet
Dim ClassName As String
Dim DataRange
Dim lRow As Long
ClassName = Worksheets("Master").Range("B2").Value
Set Class_A = ThisWorkbook.Worksheets(ClassName)
DataRange = Worksheets("Master").Range("B5:B8")
lRow = Class_A.Range("A" & Rows.Count).End(xlUp).Row + 1
Class_A.Range("A" & lRow).Resize(1, UBound(DataRange, 1)).Value = _
Application.Transpose(DataRange)
End Sub
But seeing as we have no idea what your source od destination data look like that's the best help I can give.
Suplimentary :
PivotCharts & Pivot Tables are awesome:
I am trying to run the Find method between two ranges in two different workbooks - If a value in the second range isn't found in the first range, then the data in the entire row to which the aforesaid cell belongs to should be copied from the second workbook and pasted in the first workbook. Each time I try to run my code I get runtime error #438 - Object doesn't support this property or method:
Option Explicit
Sub Data_Transfer()
Dim FileToOpen As Variant
Dim FileCount As Byte, SheetCount As Byte, SheetFound As Byte
Dim SelectedBook As Workbook
Dim WkSh As Worksheet
Dim Cell As Range, ChosenCell As Range, LookInRange As Range, LookAtRange As Range
FileToOpen = Application.GetOpenFilename(Title:="Select Files to Import Data", FileFilter:="Excel Files(*.xls*), *.xls*", MultiSelect:=True)
If IsArray(FileToOpen) Then 'Allows the user to click on the 'Cancel' button without it leading to an error
For FileCount = 1 To UBound(FileToOpen)
Set SelectedBook = Workbooks.Open(FileToOpen(FileCount))
'If a worksheet already exists for the month:
For SheetCount = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(SheetCount).Name = VBA.Replace(SelectedBook.Name, ".xls", "") Then
SheetFound = 1
Set WkSh = ThisWorkbook.Worksheets(SheetCount)
WkSh.Activate
MsgBox "A worksheet already exists for the selected month."
'Check if there are any expenses missing for the month:
Set LookInRange = ThisWorkbook.ActiveSheet.Range("C2:C" & Range("C2").End(xlDown).Row)
Set LookAtRange = SelectedBook.ActiveSheet.Range("C23:C" & Range("C2").End(xlDown).Row)
For Each Cell In LookAtRange
Set ChosenCell = LookAtRange.Find(LookInRange.Cell, , xlValues, xlWhole)
If ChosenCell Is Nothing Then
ChosenCell.EntireRow.Copy WkSh.Range("A" & Range("A1").End(xlDown).Row + 1)
End If
Next Cell
End If
If SheetFound = 1 Then: Exit Sub
Next SheetCount
'If a worksheet does not exist for the month:
With ThisWorkbook
.Worksheets.Add After:=Sheet11
.ActiveSheet.Name = VBA.Replace(SelectedBook.Name, ".xls", "")
SelectedBook.Worksheets(1).Range("A23").CurrentRegion.Copy .ActiveSheet.Range("A1")
SelectedBook.Close
For Each Cell In .ActiveSheet.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If VBA.Left(Cell.Value, 1) = "*" Then
Cell.EntireRow.Delete
End If
Next Cell
.ActiveSheet.Columns.AutoFit
End With
Next FileCount
End If
End Sub
Always specify for all Range, Cells, Rows and Columns objects in which workbook and worksheet they are.
If you don't do that for example like here:
Set LookAtRange = SelectedBook.ActiveSheet.Range("C23:C" & Range("C2").End(xlDown).Row)
Then the first Range is in SelectedBook.ActiveSheet but the second may be or may be not! As long it is not defined you don't know:
Set LookAtRange = SelectedBook.ActiveSheet.Range("C23:C" & SelectedBook.ActiveSheet.Range("C2").End(xlDown).Row)
So make clear that Range, Cells, Rows and Columns objects are always fully referenced to a workbook/worksheet.
I have a workbook that has 4 different sheets for inventory purposes (each sheet corresponds to a type of inventory to make organizing easier). Not the best setup, but I have a barcode lookup system where I scan the item's barcode and Excel finds and highlights the corresponding row (containing info like name, picture, quantity, etc.) that's all updated manually. Originally everything was on one sheet but recently I have sorted them out into 4 different sheets. Since then the barcode lookup only works on the original inventory sheet (makes sense since the code was only for that one sheet). I have been unable to figure out how to change the code to work on the whole workbook. I have tried to change worksheet to workbook (didn't work), then I tried to add a Set ws = ThisWorkbook.Sheets("") for each sheet (also didn't work) and a handful of other changes. If anyone has any idea on how to change it so it searches the workbook instead of the one sheet I would appreciate it.
Here is a copy of the working code for the first sheet:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Inventory List")
Dim rangeToLook As Range
Set rangeToLook = ws.Range("C3:C1000")
Dim wholeRange As Range
Set wholeRange = rangeToLook.Resize(, 10)
' change 14408667 to yours grey color code here
wholeRange.Cells.Interior.Color = 14408667
Dim code As Variant
code = InputBox("Please scan a barcode and hit enter if you need to")
Dim matchedCell As Range
Set matchedCell = rangeToLook.Find(what:=code, LookIn:=xlValues, _
lookat:=xlWhole, MatchCase:=True)
If Not matchedCell Is Nothing Then
With matchedCell
Application.Goto .Cells(1)
.Resize(1, 10).Interior.ColorIndex = 20
End With
Else
MsgBox "Barcode Not Found"
End If
End Sub
Thank you for the help in advance.
Try this code:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rangeToLook As Range
Dim wholeRange As Range
Dim code As Variant
Dim matchedCell As Range
code = InputBox("Please scan a barcode and hit enter if you need to")
For Each ws In ThisWorkbook.Sheets
Set rangeToLook = ws.Range("C3:C1000")
Set wholeRange = rangeToLook.Resize(, 10)
wholeRange.Interior.Color = 14408667
Set matchedCell = rangeToLook.Find(what:=code, LookIn:=xlValues, _
lookat:=xlWhole, MatchCase:=True)
If Not matchedCell Is Nothing Then
With matchedCell
Application.Goto .Cells(1)
.Resize(1, 10).Interior.ColorIndex = 20
Exit For
End With
End If
Next
If matchedCell Is Nothing Then
MsgBox "Barcode Not Found"
End If
End Sub
I'm currently doing VBA project which need to copy from a workbook to another, which the WBookPst is the workbook I firstly open (use) meanwhile WBookCopy is the workbook where I open based on the links where I got by listing all ".xslt" format in a File into my Sheet1 of my first workbook. Here is my code :
Sub SortFiles()
'Set up your variables and turn off screen updating.
'Dim iCounter As Integer
Application.ScreenUpdating = False
'Sort the rows based on the data in column C
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim filePath As String
Dim sheetName As String
Dim sheetCopy As Worksheet
Dim sheetPate As Worksheet
Dim rngCopy As Range
Dim rngPst As Range
filePath = Range("B2").Value
Set WBookCopy = Workbooks.Open(filePath)
Columns(30).Insert
For i = 1 To Sheets.count
Cells(i, 30) = Sheets(i).Name
Next i
sheetName = Range("AD1").Value
Set sheetCopy = WBookCopy.Worksheets(sheetName)
Set rngCopy = sheetCopy.Range("A:AA").Copy
Set WBookPst = ThisWorkbook
Set sheetPaste = WBookPst.Worksheets("Sheet1").Activate
Set rngCopy = sheetPaste.Range("A:AA").Select
ActiveSheet.Paste
End Sub
At Set rngCopy = sheetCopy.Range("A:AA").Copy there's error "Objects required".
What does that mean?
By the way, is how I copy and paste the data between sheets correct?
The issue is that rngCopy is of type range and you can't set it equal to a method (copy). Remove the .Copy and you should be fine. You also don't need to set the worksheet out range to a variable. You could just do one line that says WBookCopy.SheetName.Range("A:AA").Copyand then another line to paste.
As #Wyatt mentioned - your copy\paste syntax is incorrect
Here are 2 ways to do it:
Worksheets("Sheet1").Range("A:AA").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
or
Worksheets("Sheet1").Range("A:AA").Copy Destination:=Worksheets("Sheet2").Range("A1")
I'm trying to write some code to transfer large amounts of user selected data from one open workbook to another. The number of rows/columns varies and the starting point in the destination workbook also varies.
I get a debug Run-time error '13': Type mismatch on the last line of code. There's probably a more elegant way to do some things like size the destination range, but everything else seems to be working as expected.
Public SourceWorkbook As Workbook
Public SourceWorksheet As Worksheet
Public DestWorkbook As Workbook
Public DestWorksheet As Worksheet
Public selectedRange As Range
Public selectedRows As Long
Public selectedColumns As Long
Sub SelectRange()
Set SourceWorkbook = ActiveWorkbook
Set SourceWorksheet = ActiveSheet
'Display the Input Box to make selection
On Error Resume Next
Set selectedRange = Application.InputBox( _
Prompt:="Select the range of cells you want to copy.", _
title:="Select Range", _
Default:=ActiveCell.Address, _
Type:=8)
' Was the Input Box canceled?
If selectedRange Is Nothing Then
MsgBox "Cancelled"
Exit Sub
End If
selectedRange.Select
'Set row and column number variables
selectedRows = Selection.Rows.Count
selectedColumns = Selection.Columns.Count
'vbModeless Form that allows user to select another open workbook and start cell. The OK button simply calls the MoveData sub.
SwitchWorkbooksForm.Show vbModeless
End Sub
Sub MoveData()
Dim DestRange As Range
Set DestWorkbook = ActiveWorkbook
Set DestWorksheet = ActiveSheet
'Start the desination range at the user select cell and Set it to the same size as the originally selected range
StartRow = ActiveCell.Row
finalRow = StartRow + selectedRows - 1
StartColumn = ActiveCell.Column
finalColumn = StartColumn + selectedColumns - 1
Range(Cells(StartRow, StartColumn), Cells(finalRow, finalColumn)).Select
Set DestRange = Selection
'Debug error on the next line
Workbooks(DestWorkbook).Worksheets(DestWorksheet).Range(DestRange).Value = _
Workbooks(SourceWorkbook).Worksheets(SourceWorksheet).Range(selectedRange).Value
End Sub
You are using the Workbooks(...) and Worksheets(...) collections by passing in workbook and worksheet objects. You should be passing in names or using the workbook and worksheet references you've assigned directly.
Workbooks(DestWorkbook.name).Worksheets(DestWorksheet.name).Range(DestRange.address).Value = _
Workbooks(SourceWorkbook.name).Worksheets(SourceWorksheet.name).Range(selectedRange.address).Value
... or,
DestRange = selectedRange.Value
You do not have to keep redefining the parents of a range object you have Set.