I'm new to VBA, but I'm trying.(-:
I have found this code, which is working wonderfully except for two problems:
1. I have to manually change the range each time I want to use it.
2. The emails aren't sent automatically. I have to hit "Send" on each 'new mail' window, and there are over a hundred windows...
Any ideas?
Thanks,
Inbar.
ASSUMES SCHOOL NAME IS COLUMN "E" This macro will copy each row into a new sheet which will be created and named as a school name using the school_name in column E. You would then have to e-mail each sheet to the respective school (which could be automated in a separate macro.
EDIT: Fixed code and tested working:
Sub SortKids()
Dim CurRow As Long
Dim LastRow As Long
Dim NameTest As String, NameStr As String
Dim DestRow As Long
Dim NewWS As Worksheet
On Error Resume Next
LastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
For CurRow = 2 To LastRow
If Sheets("Master").Range("E" & CurRow).Value = "" Then
NameStr = "Error"
Else
NameStr = Sheets("Master").Range("E" & CurRow).Value
End If
NameTest = Worksheets(NameStr).Name
If Err.Number = 0 Then
Else
Err.Clear
Set NewWS = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
NewWS.Name = NameStr
Sheets("Master").Rows(1).Copy
Sheets(NameStr).Rows(1).PasteSpecial
End If
DestRow = Sheets(NameStr).Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Master").Rows(CurRow).Copy
Sheets(NameStr).Rows(DestRow).PasteSpecial
Next CurRow
MsgBox "Done"
End Sub
Related
i would like to come up with vba sub that searching value from one specified cell (job) across all sheets and then pastes rows but only with selected columns. If value not found any error message instead paste value.
I know it's bigger project but I'm fresh so try to my best.
As far i have solution for whole rows:
Sub TEST()
Dim tws As String
Dim l_row As String
Dim l_rowR As String
Dim job As String
Dim i As Integer
Set tws = ThisWorkbook.Sheets("Data")
tws.Range("A20") = "STATS:"
job = tws.Range("B5")
lastRow = Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row
lastRowRpt = tws.Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To lastRow
If Worksheets("Sheet1").Range("E" & i).Value = job And _
Worksheets("Sheet1").Range("D" & i).Value = "x2" Then
Worksheets("Sheet1").Rows(i).Copy
lastRowRpt = tws.Range("A" & Rows.Count).End(xlUp).Row
tws.Range("A" & lastRowRpt + 1).Select
tws.Paste
End If
Next i
End Sub
I am trying to get the data from the other Excel workbook into Userform. So when selected from the Dropdown list the user get automatcally fill the textboxes.
Below is the Code I tried but showing error. Please help me to resolve this issue.
Private Sub cmbls_DropButtonClick()
Dim i As Long, LastRow As Long
Dim w As Workbook
Set w = Workbooks.Open("C:\Users\Desktop\Inputs for Gate 1.xlsx")
Set ssheet = w.Worksheets("Sheet1")
'showing error in the below line LastRow'
LastRow = Sheets(“Sheet1”).Range(“A” & Rows.Count).End(xlUp).Row
If Me.cmbls.ListCount = 0 Then
For i = 2 To LastRow
Me.cmbls.AddItem Sheets(“Sheet1”).Cells(i, “A”).Value
Next i
End If
End Sub
Private Sub cmbls_Change()
Dim i As Long, LastRow As Long
Dim w As Workbook
Set w = Workbooks.Open("C:\Users\Inputs for Gate 1.xlsx")
Set ssheet = w.Worksheets("Sheet1")
LastRow = Sheets(“Sheet1”).Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets(“Sheet1”).Cells(i, “A”).Value = (Me.cmbls) Or _
Sheets(“Sheet1”).Cells(i, “A”).Value = Val(Me.cmbls) Then
Me.TextBox1 = Sheets(“Sheet1”).Cells(i, “B”).Value
End If
Next
End Sub
The error is due to Smart Quotes wrapping your sheet and range references.
Remove all Smart Quotes with CTRL + F & Find and Replace All swapping (“) & (”) for the correct quote notation, (").
Note the subtle difference betwen the 3 quotes used below. VBA requires the 3rd
“ <> ” <> "
Here are some other updates. You did not declare your worksheet reference and need to qualify all of your objects. This compiles now, but may still produce Run Time Errors or may have Logic Errors present.
Option Explicit
Private Sub cmbls_DropButtonClick()
Dim WB As Workbook: Set WB = Workbooks.Open("C:\Users\Desktop\Inputs for Gate 1.xlsx")
Dim WS As Worksheet: Set WS = WB.Worksheets("Sheet1")
Dim i As Long
If Me.cmbls.ListCount = 0 Then
For i = 2 To WS.Range("A" & WS.Rows.Count).End(xlUp).Row
Me.cmbls.AddItem Sheets("Sheet1").Cells(i, "A").Value
Next i
End If
End Sub
Private Sub cmbls_Change()
Dim WB As Workbook: Set WB = Workbooks.Open("C:\Users\Inputs for Gate 1.xlsx")
Dim WS As Worksheet: Set WS = WB.Worksheets("Sheet1")
Dim i As Long
For i = 2 To WS.Range("A" & WS.Rows.Count).End(xlUp).Row
If WS.Cells(i, "A").Value = (Me.cmbls) Or WS.Cells(i, "A").Value = Val(Me.cmbls) Then
Me.TextBox1 = WS.Cells(i, "B").Value
End If
Next i
End Sub
I have written a code which gives me the errors (if any cell is non numeric) in a separate sheet called "Error_sheet".
But the output is a bit clumsy as it gives me non numeric cell address in a confusing fashion. Like the errors will not be pasted one after another. There will be some blanks in between if there are more than one non Numeric cells.
Sub Test()
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If IsNumeric(Range("A" & i).Value) Then
Else
Sheets("Error").Range("A" & Row).Value = "Error in" & i & " row of ColumnNAme"
Row = Row + 1
End If
Next i
End Sub
It gives me output like shown below but can I get the output like Error in 7,14 rows of column name in a desired cell of "Error_sheet".
[![Output][1]][1]
[1]: https://i.stack.imgur.com/JqXwq.png
My understanding of what you've written is that you want something like this.
Option Explicit
Sub Test()
' Unqualified book/sheet below, means code will always run the isnumeric check on the cells of the active sheet. Is that what you want? '
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim Index as long
Dim i As Long
Dim NonNumericRows() as string
Redim NonNumericRows(1 to lastrow)
For i = 2 To LastRow
If not(IsNumeric(Range("A" & i).Value)) Then
Index = index + 1
NonNumericRows(Index) = cstr(i)
End if
Next i
Redim preserve NonNumericRows(1 to index)
Sheets("Error").Range("A1").Value = "Error in row(s): " & strings.join(nonnumericrows,", ") & " of ColumnNAme"
End Sub
Hope it works or helps.
Like QHarr suggested, using Option Explicit is normally a good idea, and try not to use VBA operators as variables.
Also when working with more than 1 sheet, its best to define each in the code. I dont know what your first sheet is called, so please change the line: Set shSource = Sheets("Sheet1") to suit:
Option Explicit
Sub SubErrorSheet()
Dim lr As Long, i As Long
Dim shSource As Worksheet, shError As Worksheet
Set shSource = Sheets("Sheet1")
Set shError = Sheets("Error")
lr = shSource.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lr
If Not IsNumeric(shSource.Range("A" & i).Value) Then
shError.Range("A" & Rows.count).End(xlUp).Offset(1, 0).Value = "Error in row " & i & " of ColumnNAme"
End If
Next i
End Sub
I'm trying to write a macro that let's the user create a new sheet, name it, and then based on what option they've chosen, will paste a certain text in that new sheet. But my searching and piecing together only got me so far.
Sub AddNameNewSheet1()
Dim Newname As String
Newname = InputBox("Name for new account?")
If Newname <> "" Then
Sheets.Add Type:=xlWorksheet
ActiveSheet.Name = Newname
Range("D1") = Newname
End If
Dim LR As Long, i As Long
With Sheets("Start Page")
LR = .Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR
With .Range("A" & i)
If .Value = "Debit" Then
Sheets("Account Styles").Range("A1:G3").Copy Destination:=Sheets("").Range("A1:G3")
ElseIf .Value = "Credit" Then
Sheets("Sheet1").Range("A1:A1").Copy Destination:=Sheets("Sheet1").Range("A2:A2")
ElseIf .Value = "Savings" Then
Sheets("Sheet1").Range("A1:A1").Copy Destination:=Sheets("Sheet1").Range("A2:A2")
End If
End With
Next i
End With
A starting point would be great, as a lot of answers I find that are relatively similar are not similar enough for me to relate it to my project. I know that code might not be fixable in its current form. So far it works until "Sheets("Account Styles").Range("A1:G3")..."
Thanks in advance.
Obviously, there is still a lot of work in your project. In the code below I have streamlined your existing code a little so that you can see your next step more clearly. I hope it helps.
Sub AddNameNewSheet1()
' 21 May 2017
Dim WsStart As Worksheet
Dim WsNew As Worksheet
Dim AccName As String
Dim Rl As Long ' last row
Dim R As Long ' row counter
AccName = InputBox("Name for new account?")
If AccName = "" Then Exit Sub
Set WsNew = Worksheets.Add
With WsNew
.Name = AccName
.Cells(1, "D").Value = AccName
End With
Set WsStart = Worksheets("Start Page")
With WsStart
Rl = .Range("A" & Rows.Count).End(xlUp).Row
For R = 1 To Rl
Select Case .Cells(R, "A").value
Case "Debit"
.Range("A1:G3").Value = Sheets("Account Styles").Range("A1:G3").Value
Case "Credit", "Savings"
.Range("A2").Value = Sheets("Sheet1").Range("A1").Value
End Select
Next R
End With
End Sub
I have the following code so far based on questions asked by other people.
I have a set of names listed in column A, and 216 columns and 9725 rows of data.
Currently using the following code I get the new sheets created except along with the unique names and its relevant data I get many cells filled with "#N/A".
In certain cases, the name Bob for example will be populated in a new sheet called Bob but the first column will have Bob and all relevant data and once all Bobs rows are shown it is follower with many rows with #N/A and all columns with #N/A.
In other cases the sheet will be created for Charles and all of Charles data will be listed, then many rows of #N/A and then all of the master-data including other peoples names which I need to avoid.
I want each individual sheet to only have the info based on the name of the person on that sheet. All of the data gets copied as I verified the number of accurate cells that get populated yet I get these #N/A cells and duplicated extra data and I'm not sure how to stop it from being populated? Any help in cleaning the code would be appreciated!!
Code:
Sub CopyDataFromReportToIndividualSheets()
Dim ws As Worksheet
Set ws = Sheets("FormulaMSheet2")
Dim LastRow As Long
Dim MyRange As Range
Worksheets("FormulaMSheet2").Activate
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
' SortMasterList LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortMasterList(LastRow As Long, ws As Worksheet)
ws.Range("A2:BO" & LastRow).Sort Key1:=ws.Range("A1")
', Key2:=ws.Range("B1")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim allAgentNameCells As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set allAgentNameCells = Range("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In allAgentNameCells
If cell.Value <> " " And cell.Value <> "" Then
' Condition ` And cell.Value <> "" ` added for my testdata. If you don't need this, please remove.
' Current Row's Series not SPACE
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
End If
Next
'' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, name As String)
Dim tgt As Worksheet
Dim MyRange As Range
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master List.", vbCritical, _
"Time Series Parser"
End
Else
If Series = " " Then
End
End If
End If
Worksheets("FormulaMSheet2").Activate
' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name
Worksheets("FormulaMSheet2").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.name = name
Set tgt = Sheets(name)
' copy data from src to tgt
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Variant
For Each ws In ThisWorkbook.Sheets
If ws.name = name Then
SheetExists = True
Exit Function
End If
Next
SheetExists = False
End Function
You need replace the
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
to
src.Range("A" & Start & ":BO" & Last).SpecialCells(xlCellTypeVisible).Copy Destination:=tgt.Range("A2:BO2" & Last - Start + 2)
I found what I needed at the following site: http://www.rondebruin.nl/win/s3/win006_5.htm .
I figured if anyone else was looking for similar code it would help taking a look at the site.