Repeat the same calculation in multiple sheets - vba

Task: Repeat an identical calculation in multiple sheets.
Background:
multiple sheets labelled by calendar date i.e. 01 04, 02 04, 03 04. These are three discrete sheet names meaning 1st April, 2nd April and 3 April. (actual workbook has all the days in the month).
Data has identical column headings, but the number of rows vary. In brief the data is a list of mastercard and visa transactions.
I want to get the total of column G (happens to contain the monetary transaction value) and only take the Visa transactions.
Result:
the code below does this fine and places the results on the same sheet merely offset by a few columns to the right hand side and highlights the value I need in red. (this is a recorded macro I completed)
Limitation and seeking advise:
1) improve code to repeat this for all sheets by a single click of a mouse button.
(as you will note, its about how to cycle through all the sheets within the same workbook rather than (at present) having to manually go into each sheet and run the macro.
thank you in advance
code is:
Sub sum_visa_trans_together()
'
' sum_visa_trans_together Macro
'
' Keyboard Shortcut: Ctrl+r
'
ActiveCell.Rows("1:1").EntireRow.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$M$14").AutoFilter Field:=2, Criteria1:="V"
ActiveCell.Offset(0, 6).Columns("A:A").EntireColumn.Select
Selection.Copy
ActiveCell.Offset(0, 4).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Rows("1:1").EntireRow.Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveCell.Offset(0, 11).Range("A1").Select
ActiveCell.FormulaR1C1 = "max"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "=MAX(C[-1])"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "=SUM(C[-1])"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "visa trans"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "=R[-2]C-R[-3]C"
ActiveCell.Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

this wont repeat in the sheets you want because you are using active cell, you can replace active cell with something like this:
sheetname.cells(1,1).value
in this case you are geting the value of cell A1 wich is row=1,column=1 in the sheet named sheetname
the name of your sheet is not necesary the same in vba so chek your narmes in the vba project explorer.
for example you can try something like this(Im not sure exactly what you are trying to do but this will guide you):
Sub s()
For Each ws In Worksheets 'WS will loop trough all worksheets
Dim TargetCell As Range
Set TargetCell = ws.Cells(1, 2) ' in this case you will run this macro in
' the cell A2 of all your sheets
TargetCell.Rows("1:1").EntireRow.Select
Selection.AutoFilter
ws.Range("$A$1:$M$14").AutoFilter Field:=2, Criteria1:="V"
TargetCell.Offset(0, 6).Columns("A:A").EntireColumn.Select
Selection.Copy
TargetCell.Offset(0, 4).Range("A1").Select
ws.Paste
TargetCell.Rows("1:1").EntireRow.Select
Application.CutCopyMode = False
Selection.AutoFilter
TargetCell.Offset(0, 11).Range("A1").Select
TargetCell.FormulaR1C1 = "max"
TargetCell.Offset(1, 0).Range("A1").Select
TargetCell.FormulaR1C1 = "=MAX(C[-1])"
TargetCell.Offset(1, 0).Range("A1").Select
TargetCell.FormulaR1C1 = "=SUM(C[-1])"
TargetCell.Offset(1, 0).Range("A1").Select
TargetCell.FormulaR1C1 = "visa trans"
TargetCell.Offset(1, 0).Range("A1").Select
TargetCell.FormulaR1C1 = "=R[-2]C-R[-3]C"
TargetCell.Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Next
End Sub

Otherwise:
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
' Insert your code here.
' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.
MsgBox ActiveWorkbook.Worksheets(I).Name
Next I
End Sub
source: http://support.microsoft.com/kb/142126/en

Related

draw borders vba excel on button with space

Hi I'm new with VBA need some help here if possible. I am trying to make 3 buttons, each button draws a top-line and a bottom line(i'll provide the excel file too):
the first button draws inside of 5 rows a top and a bottom line.
the second button draws inside of 10 rows a top and a bottom line.
the third button draws inside of 20 rows a top and a bottom line.
What I'm trying to achieve:
every time I press button 1 to keep count if already has been drawn the borders, if I press twice in a row button 1 to keep count if I already have drawn the borders, and draw again after keeping a space of 2 rows in between....Same if I would've pressed Button1, then Button 2. Or button 3.
..I am new with VBA I would love some help....
ub Macro2()
'
' Macro2 Macro
'
'
Range("A13:BD23").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A27").Select
ActiveWindow.SmallScroll Down:=12
Range("A27").Select
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
Range("A4:J8").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("C9").Select
End Sub
Sub Macro3()
'
' Macro3 Macro
'
'
Range("A26:P46").Select
ActiveWindow.SmallScroll Down:=-6
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("G34").Select
ActiveWindow.SmallScroll Down:=-15
End Sub
DL LINK:
https://mega.nz/#!sgkVATKQ!k-Nq5gpKf4NfW2afEM8wpg_T5RFqT6y2_iqH7lDTM40
Not sure I completely followed your description, but try this:
EDIT - added a way to reset the "last range" so you can start over.
Option Explicit
Sub DoFive()
DoBorders Range("A4:J8")
End Sub
Sub DoTen()
DoBorders Range("A13:BD23")
End Sub
Sub DoTwenty()
DoBorders Range("A26:P46")
End Sub
'this is called to reset the starting point to whatever is passed.
Sub ResetStart()
DoBorders Nothing
End Sub
Sub DoBorders(rng As Range)
Dim useRange As Range
Static lastRange As Range
'handle resetting the "last range"
If rng Is Nothing Then
Set lastRange = Nothing
Exit Sub
End If
If lastRange Is Nothing Then
Set useRange = rng
Else
Set useRange = lastRange.Cells(1).Offset(lastRange.Rows.Count + 2, 0) _
.Resize(rng.Rows.Count, rng.Columns.Count)
End If
Set lastRange = useRange 'save for next call
With useRange
.Borders.LineStyle = xlNone 'remove all borders
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
End With
End Sub

VBA - Selecting Data

I'm new to VBA entirely but have spent about a week tinkering with it. I'm in the process of trying to automate a pretty intensive task in excel through a combination of recording and messing about with the code from internet searches and my limited research into VBA. I've actually gotten pretty far into the process, but I've run into a problem that I can't seem to find info on. I assume it's a common issue so there is probably already stuff on it, I'm just not typing in the magic combination of words to search for the right answers.
My problem is this: I have a worksheet with about 10,000 rows of data and from this raw data I need to create 60 or so separate spreadsheets for 60 different companies- so around 160 some row actually pertain to a given client. However, it's not fixed and from one month to the next the actual number of rows changes so I can't just use a simple range. There are two possible ways to mark that the data pertains to a new client. In column 1 if the cell says null, it marks the start of new client data. Or, column 2 contains the name of the client, so if the cell in column b does not equal the cell directly above it also will mark the start of new client data.
The key point is that I need to select and cut all the data for each client and paste it into a newly opened workbook.
I've looked into a couple of ways to do this and am now researching for loops and while loops. can anyone suggest a possible structure to do this or a resource that might help?
Updated Code:
Sub copyStuff()
Dim rowStart As Integer
Dim rowEnd As Integer
Dim rowMax As Integer
Dim colMax As Integer
Dim bookName As String
Dim thisWB As String
thisWB = ThisWorkbook.Name
rowMax = ActiveSheet.UsedRange.Rows.Count + 1
colMax = ActiveSheet.UsedRange.Columns.Count
rowStart = 2
For x = 3 To rowMax
If Cells(x, 2) = Cells(x - 1, 2) Then
'
Else
rowEnd = x - 1
Range(Cells(rowStart, 1), Cells(rowEnd, colMax)).Copy
Set NewBook = Workbooks.Add
Range("A2").PasteSpecial (xlPasteValues)
bookName = Cells(rowStart, 2).Value
NewBook.SaveAs Filename:=bookName
Workbooks(thisWB).Activate
Range(Cells(1, 1), Cells(1, colMax)).Copy
Workbooks(bookName).Activate
Range("A1").PasteSpecial (xlPasteValues)
ActiveSheet.Name = "Daily Summary"
ActiveWorkbook.Save
Workbooks(thisWB).Activate
Worksheets("transaction details").Activate
If Cells(x, 2) = Cells(x - 1, 2) Then
'
Else
rowEnd = x - 1
Range(Cells(rowStart, 1), Cells(rowEnd, colMax)).Copy
NewBook.Activate
Range("A2").PasteSpecial (xlPasteValues)
Sheets.Add.Name = "Transaction Details"
Workbooks(thisWB).Worksheet("Transaction Details").Activate
Range(Cells(1, 1), Cells(1, colMax)).Copy
Workbooks(bookName).Activate
Range("A1").PasteSpecial (xlPasteValues)
End If
Workbooks(bookName).Activate
Worksheets("Daily Summary").Activate
Columns("B").Delete
Range("A1:O1").Select
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A30:O30").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Range("C2:O29").Select
Range("C29").Activate
Selection.Style = "Currency"
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
ActiveCell.Replace What:="Null", Replacement:="Total", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("D22").Select
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWorkbook.Sheets.Add.Name = "Summary"
ActiveWorkbook.Worksheets("Summary").Activate
Range("A1").Select
ActiveCell.FormulaR1C1 = "Description"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=EOMONTH(TODAY(),-2)+1"
Selection.NumberFormat = "m/d/yyyy"
Range("A1:B1").Select
Range("A1:B1").Select
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B1").Select
CellContentCanBeInterpretedAsADate = True
Range("A2").Select
ActiveCell.FormulaR1C1 = "Total Amex Charges"
Range("A3").Select
ActiveCell.FormulaR1C1 = "Total Visa Charges"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Total MasterCard Charges"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Total Discover Charges"
Range("A6").Select
ActiveCell.FormulaR1C1 = "Total Credit Card Charges"
Range("A6:B6").Select
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Cells.Select
Cells.EntireColumn.AutoFit
Range("A8").Select
ActiveCell.FormulaR1C1 = "Amex Transaction Fee (.05/per)"
Range("A9").Select
ActiveCell.FormulaR1C1 = "MasterCard Card Fees"
Range("A10").Select
ActiveCell.FormulaR1C1 = "Visa Card Fees"
Range("A11").Select
ActiveCell.FormulaR1C1 = "Discover Fees"
Range("A12").Select
ActiveCell.FormulaR1C1 = "Total Card Fees"
Range("A12:B12").Select
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Cells.Select
Cells.EntireColumn.AutoFit
Range("A14").Select
ActiveCell.FormulaR1C1 = "xx Management Fee"
Range("A15").Select
ActiveCell.FormulaR1C1 = "Total xx Fees"
Range("A15:B15").Select
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A17").Select
ActiveCell.FormulaR1C1 = "Equipment Payment Fee"
Range("A18").Select
ActiveCell.FormulaR1C1 = "Total Equipment Fees"
Range("A18:B18").Select
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A20").Select
ActiveCell.FormulaR1C1 = "Total Visa, MasterCard, Discover Charges"
Range("A21").Select
ActiveCell.FormulaR1C1 = "Less: Total Fees"
Range("A22").Select
ActiveCell.FormulaR1C1 = "Total Amount Owed"
Range("A23").Select
ActiveCell.FormulaR1C1 = "Total ACH Payments"
Range("A24").Select
ActiveCell.FormulaR1C1 = "Overpaid (UnderPaid)"
Range("A24:B24").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A22:B22").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A20:B20").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A20:B20,A22:B22,A24:B24").Select
Range("A24").Activate
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
Range("B2:B24").Select
Selection.Style = "Currency"
Range("B2").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 2).Value
Range("B3").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 4).Value
Range("B4").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 5).Value
Range("B5").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 3).Value
Range("B6").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 6).Value
Sheets("Daily Summary").Select
Columns("G:G").Select
Selection.Cut
Columns("O:O").Select
Selection.Insert Shift:=xlToRight
Sheets("Summary").Select
Range("B8").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 10).Value
Range("B9").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 7).Value
Range("B10").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 8).Value
Range("B11").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 9).Value
Range("B12").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 11).Value
Range("B14").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 12).Value
Range("B15").Select
ActiveCell.FormulaR1C1 = "=R[-1]C"
Range("B17").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 13).Value
Range("B18").Select
ActiveCell.FormulaR1C1 = "=R[-1]C"
Range("B20").Select
ActiveCell.FormulaR1C1 = "=R[-17]C+R[-16]C+R[-15]C"
Range("B21").Select
ActiveCell.FormulaR1C1 = "=R[-9]C+R[-6]C+R[-3]C"
Range("B22").Select
ActiveCell.FormulaR1C1 = "=R[-2]C-R[-1]C"
Range("B22").Select
ActiveCell.FormulaR1C1 = "=R[-2]C-R[-1]C"
Range("B21").Select
ActiveCell.FormulaR1C1 = "=R[-9]C+R[-6]C+R[-3]C"
Range("B23").Select
ActiveCell.FormulaR1C1 = Sheets("Daily Summary").Cells(rowEnd, 16).Value
Range("B24").Select
ActiveCell.FormulaR1C1 = "=R[-2]C-R[-1]C"
Range("B25").Select
ActiveWorkbook.Close
rowStart = x
Sheets("Data").Activate
End If
Next
End Sub
Here's what I think you're looking for. This will loop through (currently) column A and look for if the cell is the same as the one above it. If it is, it will skip to the next row and continue looking.
When it comes across a change in cells, it will then copy from the start of the range to the end and paste it into a new workbook. It currently names the book whatever the cell value is. So it will, in theory, name it the company name.
Sub copyStuff()
Dim rowStart As Integer
Dim rowEnd As Integer
Dim rowMax As Integer
Dim colMax As Integer
Dim bookName As String
Dim thisWB As String
thisWB = ThisWorkbook.Name
rowMax = ActiveSheet.UsedRange.Rows.Count + 1
colMax = ActiveSheet.UsedRange.Columns.Count
rowStart = 2
For x = 3 To rowMax
If Cells(x, 1) = Cells(x - 1, 1) Then
'
Else
rowEnd = x - 1
bookName = Cells(rowEnd, 1).Value
Range(Cells(rowStart, 1), Cells(rowEnd, colMax)).Copy
Set NewBook = Workbooks.Add
Range("A2").PasteSpecial (xlPasteValues)
NewBook.SaveAs Filename:=bookName
Workbooks(thisWB).Activate
Range(Cells(1, 1), Cells(1, colMax)).Copy
Workbooks(bookName).Activate
Range("A1").PasteSpecial (xlPasteValues)
ActiveWorkbook.Save
ActiveWorkbook.Close
rowStart = x
Sheets("Data").Activate
End If
Next
End Sub

How Do You Put Borders Round Cells A to J When The Data Changes In Column F

Please can you help!
I am trying to put around data when the value is the same in column F which starts in cell F4. I have the boarder coding below but am unsure how to select the data required
My data starts in cell A4 through to column J and varies in length. the data in column F is a 20xx date and I would like to border around A through to J and down to box where the date is the same.
I would then like it to continue down the rest of the report until all dates are bordered
Then add two rows at the bottom with 6 height and the last one is coloured in blue the border should then be put around the whole are that starts from A3 to J varied length.
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
If anyone can help with this it would be most appreciated.
Give this a go. You may need to modify some of the ranges or your border styles. Let me know how you go with it.
Sub borderData()
Dim dataStartRow As Long
Dim dataEndRow As Long
Dim sameDateRowStart As Long, sameDateRowEnd As Long
sameDateRowStart = 0
sameDateRowEnd = 0
dataStartRow = 5
dataEndRow = Range("A" & dataStartRow).End(xlDown).Row
'// remove any existing borders
With Range("A" & dataStartRow & ":J" & dataEndRow)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
End With
'// loop through data and border rows with same date
For i = dataStartRow To dataEndRow + 1
If Range("F" & i) <> Range("F" & i - 1) Then
If sameDateRowStart <> 0 And sameDateRowEnd <> 0 Then
With Range("A" & sameDateRowStart & ":J" & sameDateRowEnd)
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
End With
End If
sameDateRowStart = i
sameDateRowEnd = i
Else
sameDateRowEnd = i
End If
Next i
End Sub
I would recommend conditional formatting. Although different request, a similar concept is shown
here in this blog:
http://excel-oh.com/?p=291
Starting in A4, create a new conditional format that looks like this:
=left($F4,2)="20"
Then apply a border format. After that apply the format accross the entire range.
You can then apply this to the range.
Then apply it to the range.

How do I sort this Macro out, so it selects the next row automatically

I am making a Movie Database on Excel, I have set it all up. Its working fine, i decided to add a Data entry form which will allow the user to input movie details in a form and automatically using a macro it would then move this data to a separate Worksheet with all my movies in. I have managed to record all this step and it works fine however it overwrites data and only uses the row that I pasted it to which was 'A47'. I now want to know how to edit the code so it changes to the next row if data is already available in this row. Another thing to note is that my macro also formats that selection, so that would need changing too. The formatting basically changes certain cells to be bold and text alignment. I will attach the code so you can see what I'm talking about. Also the code at the end deletes the data in the data entry form so its fresh for another entry.
Sorry I'm new to this all, I have looked around but no one has a similar problem as mine.
Any help would be appreciated.
Thanks
Sub SubmitMovie()
'
' SubmitMovie Macro
'
'
Range("K9,K11,K13,K15,K17,K19,K21").Select
Range("K21").Activate
Selection.Copy
Sheets("MovieList").Select
Range("A74:G74").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B74").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("D74").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A74:G74").Select
Range("G74").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Sheets("Add New Movie").Select
Range("K9").Select
ActiveCell.FormulaR1C1 = ""
Range("K11").Select
ActiveCell.FormulaR1C1 = ""
Range("K13").Select
ActiveCell.FormulaR1C1 = ""
Range("K15").Select
ActiveCell.FormulaR1C1 = ""
Range("K17").Select
ActiveCell.FormulaR1C1 = ""
Range("K19").Select
ActiveCell.FormulaR1C1 = ""
Range("K21").Select
ActiveCell.FormulaR1C1 = ""
Range("D28").Select
End Sub
Replace this
Range("K9,K11,K13,K15,K17,K19,K21").Select
Range("K21").Activate
Selection.Copy
Sheets("MovieList").Select
Range("A74:G74").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
with
Dim dest as Range
Activesheet.Range("K9,K11,K13,K15,K17,K19,K21").Copy
'find the first non-empty cell in ColA (from bottom up)
Set dest = Sheets("MovieList").Cells(rows.count,1).End(xlUp).offset(1,0)
dest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:= False, Transpose:=True
Welcome to SO.
Since you are new to VBA you have chosen a good way to start learning more by using the macro recorder, but you have already learned that it has its limitations. It doesn't always do things in the most efficent way.
Some pointers on how to improve the script:
Remove all code that you don't know what it does. Most of it should be self explanatory, but if you don't know what it does, chances are you don't need it, because the macro recorder adds lots of uneccessary stuff.
Avoid using Select to navigate the worksheet. It is very inefficient and will slow down your code: tips on how to avoid using select.
There are lots of questions on SO about finding the last used row in order to know where new data can be saved.
Use Option Explicit at the top of each code module to minimize confusion and errors caused by typos etc. It will force you to explicitly declare all variables used, which is a good thing since VBA otherwise will accept all variable names as new variant-types if they haven't been declared before.
If you get stuck on a specific problem - ask questions on that specific problem.
This previous post should help you see some of the concepts/syntax involved in the solution: Loops & Rows
The bottom line is you've run into an issue that macro recorder cannot get you out of. It would be really beneficial for you to take some time to learn about loops, counts and the Cells() function in VBA. Olle and Tim are spot on...especially Tim's "Set dest =" line.
This link shows a good example of loop syntax and may be a help to you on future problems of a similar nature:
Looping Through Ranges

Excel vba count headers and copy active row of same length to new sheet

I'm new to vba and struggling with a macro.
I have recorded a macro and then tried to adapt it.
What I have is a list of drivers as headers currently c1:t1 but as I add or remove drivers I need the selection below to adapt.
B2 is a merged cell (B2:B5) with the date in and the columns across are still individual cells.
The date is repeated all the way down in the same format for each day of the year.
What i'm trying to do is select a date and press ctrl+q and copy the list of drivers names across the headers to a new sheet in column A and the selected date and the number of columns to match the number of drivers in the header.
Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+q
'
Selection.Copy
Sheets("Daily").Select
Range("C4:F4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Sheets("Weekly").Select
Range("c1", Range("CV1").End(xlToLeft)).Select
Selection.Copy
Sheets("Daily").Select
Range("A5").Select
ActiveWindow.SmallScroll Down:=-27
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Sheets("Weekly").Select
Application.CutCopyMode = False
Sheets("Daily").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.ClearComments
Sheets("Weekly").Select
Application.CutCopyMode = False
End Sub
Dim lCol As Long, cpycel As Range
Set cpycel = Range(ActiveCell.Address)
lCol = (Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column) - 1
cpycel.Resize(4, lCol).Select
Selection.Copy
Sheets("Daily").Select
Range("C4:F4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Sheets("Weekly").Select
Range(Cells(1, 2), Cells(1, (lCol + 1))).Select
Selection.Copy
Sheets("Daily").Select
Range("a4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Range(Cells(5, 1), Cells((lCol + 3), 6)).Select