Is there any way to automatically arrange this data
Into this
Using excel/google sheets/etc. Basically I have a huge list of files (second column) that I need to map to it's respective folder (first column ID).
What I need, is to copy column A data down, but only to the blank cells immediately below, and then do it again for the new folder id, and so on.
I happen to have a macro that prompts the user which column to copy data down. See the below (Note you may need to tweak as necessary):
Sub GEN_USE_Copy_Data_Down()
Dim screenRefresh$, runAgain$
Dim lastRow&, newLastRow&
Dim c As Range
Dim LastRowCounter$
Dim columnArray() As String
screenRefresh = MsgBox("Turn OFF screen updating while macro runs?", vbYesNo)
If screenRefresh = vbYes Then
Application.ScreenUpdating = False
Else
Application.ScreenUpdating = True
End If
Dim EffectiveDateCol As Integer
LastRowCounter = InputBox("What column has the most data (this info will be used to find the last used row")
CopyAgain:
With ActiveSheet
lastRow = .UsedRange.Rows.Count
End With
' THIS WILL ASK THE USER TO SELECT THE COLUMN TO COPY DATA DOWN
MsgBox ("Now, you will choose a column, and that column's data will be pasted in the range" & vbCrLf & "below the current cell, to the next full cell")
Dim Column2Copy As String
Column2Copy = InputBox("What columns (A,B,C, etc.) would you like to copy the data of? Use SPACES, to separate columns")
columnArray() = Split(Column2Copy)
Dim startCell As Range
For i = LBound(columnArray) To UBound(columnArray)
Debug.Print i
Column2Copy = columnArray(i)
Set startCell = Cells(1, Column2Copy).End(xlDown)
Do While startCell.row < lastRow
If startCell.End(xlDown).Offset(-1, 0).row > lastRow Then
newLastRow = lastRow
Else
newLastRow = startCell.End(xlDown).Offset(-1, 0).row
End If
Set CopyFrom = startCell
Range(Cells(startCell.row, Column2Copy), Cells(newLastRow, Column2Copy)).Value = CopyFrom.Value
Set startCell = startCell.End(xlDown)
Loop
Next i
If screenRefresh = vbYes Then
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = True
End If
End Sub
I wrote it a while ago, so it might be able to have lines removed/combined, but it should work (assuming you're trying to just copy data down column A).
In Excel, select the left-hand column, HOME > Editing, Find & Select, Go to Special..., check Blanks (only), OK, then select one of the chosen cells, =, Up, Ctl+Enter.
Related
Good evening. I am developing a subroutine for a project whereby the user is able to upload specific data from a separate workbook into the master. The routine will search through the chosen excel file for specific column headers and only copy/paste those desired columns to the master sheet. This is my first coding project and I think I have the process mostly sorted, however there is one bit of functionality that is eluding me: The specific column titles are moderately similar no matter the workbook, except they may vary between full name and abbreviation. For example the title of the column may be "AZM" or it may be "Azimuth". Alternatively one column title may be "N/S", "Northing" or "NS". There will never be multiple of these titles, just the one in the format that the workbook creator decided to go with.
My current code does not currently account for that:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim wb As Workbook
Dim filename As String, colName As String
Dim LRow As Long, LCol As Long
Dim pColName As String, MyHead(1 To 8) As String
Dim sCell As Range, PRng As Range
Dim col As Long, pCol As Long
MsgBox "Ensure plan includes MD/INC/AZM/TVD/NS/EW/VS/DLS"
With Application.FileDialog(msoFileDialogOpen) 'Open file explorer
.AllowMultiSelect = False 'Only allow one file to be chosen
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1 'Limit selection options to excel files
If .Show Then
filename = .SelectedItems(1) 'Assign file path to variable filename
Set wb = Workbooks.Open(filename:=filename) 'Set selected Excel file to variable wb
MyHead(1) = "MD"
MyHead(2) = "Inc"
MyHead(3) = "Azimuth"
MyHead(4) = "TVD"
MyHead(5) = "N/S"
MyHead(6) = "E/W"
MyHead(7) = "VS"
MyHead(8) = "DLS"
If Not IsEmpty(ThisWorkbook.Worksheets("5D-Lite").Range("M33")) Then
LRow = Cells(Rows.Count, 13).End(xlUp).Row 'Find the last row of data in column M from previous plan
LCol = Cells(LRow, Columns.Count).End(xlToLeft).Column 'Find the last column of data in the last row
ThisWorkbook.Worksheets("5D-Lite").Range("M33:" & Col_Letter(LCol) & LRow).ClearContents 'Clear the contents of the range determined by the Last functions
End If
With wb.Worksheets(1)
For i = LBound(MyHead) To UBound(MyHead)
Set sCell = .Range("A1:R50").Find(What:=MyHead(i), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) 'Search for the desired directional plan items in column headers
If Not sCell Is Nothing Then
col = sCell.Column 'Located item's column number
pCol = i + 12 'Column number in master workbook to paste in
colName = Split(.Cells(, col).Address, "$")(1) 'Located item's column letter
pColName = Split(.Cells(, pCol).Address, "$")(1) 'Column letter in master workbook to paste in
LRow = FindLastNumeric() 'Find the final row with numeric data
Set PRng = .Range(sCell.Address & ":" & colName & LRow) 'Set total data range of desired column
wb.Activate
wb.Worksheets(1).Range(PRng.Address).Copy ThisWorkbook.Worksheets("5D-Lite").Range(pColName & "32") 'Copy contents of selected file to the 5D sheet
End If
Next
Range("M32:T" & LRow + 33).NumberFormat = "0.00" 'Assigns numeric formatting to the pasted data range
wb.Close SaveChanges:=False
Set wb = Nothing
End With
Else
MsgBox "No Plan Selected"
End If
End With
Application.ScreenUpdating = True
End Sub
Is there any way to modify the .Find function or the MyHead(i) variables to account for multiple possible variations on the same header name? Thanks for any ideas.
It looks to me like you need prepare some kind of a dictionary. A simple solution would be to have an Excel table which stores all the information, which is stored in an array on startup (for quicker references) and then used to translate inputs to outputs. It could look something like this:
POSSIBLE_SOURCE VALID_NAME
appl apple
apple apple
orng orange
orange orange
To use this you would search the source files for matches in POSSIBLE_SOURCE column, find corresponding value in VALID_NAME column and use the latter for whatever you need to do with the input row.
This question already has answers here:
Filling any empty cells with the value above
(6 answers)
Closed 7 years ago.
I have some blank cells in Excel like Figure 1. I want to fill those blank cells like Figure 2. I mean, I want to fill the blank cells by the next non-blank value.
I want to do it with a single command as I have high volume of data. Can anyone help me to do this?
Ecology,
In MS Excel you can automatically fill data in adjacent cells using the "Fill Command".
Please take a look at: https://support.office.com/en-za/article/Fill-data-automatically-in-worksheet-cells-74e31bdd-d993-45da-aa82-35a236c5b5db
You can also do this using VBA.
http://www.extendoffice.com/documents/excel/771-excel-fill-blank-cells-with-value-above.html
I have a "general" macro I use to copy data down a column, which I have tweaked for you, since you want to copy up. Here's a solution in VBA:
Sub GEN_USE_Copy_Data_Up_Column()
Dim screenRefresh As String, runAgain As String
Dim lastRow As Long, newLastRow As Long
Dim CopyFrom As Range
Dim LastRowCounter As String
screenRefresh = MsgBox("Turn OFF screen updating while macro runs?", vbYesNo)
If screenRefresh = vbYes Then
Application.ScreenUpdating = False
Else
Application.ScreenUpdating = True
End If
Dim EffectiveDateCol As Integer
LastRowCounter = InputBox("What column has the most data (this info will be used to find the last used row). Use Letters")
CopyAgain:
With ActiveSheet
'lastRow = .Cells(.Rows.Count, LastRowCounter).End(xlUp).row
lastRow = .UsedRange.Rows.Count
End With
' THIS WILL ASK THE USER TO SELECT THE COLUMN TO COPY DATA DOWN
MsgBox ("Now, you will choose a column, and that column's data will be pasted in the range below the current cell, to the next full cell")
Dim Column2Copy As String
Column2Copy = InputBox("What column (A,B,C, etc.) would you like to copy the data of?")
Dim startCell As Range
Set startCell = Cells(1048576, Column2Copy).End(xlUp)
'Cells(1, Column2Copy).End(xlDown).Select
Do While startCell.Row > 1
If startCell.End(xlUp).Row = 1 Then
newLastRow = 1
Else
newLastRow = startCell.End(xlUp).Offset(1, 0).Row
End If
Set CopyFrom = startCell
If startCell.Row Mod 5 = 0 Then Debug.Print startCell.Row
Range(Cells(startCell.Row, Column2Copy), Cells(newLastRow, Column2Copy)).Value = CopyFrom.Value
Set startCell = startCell.End(xlUp)
'startCell.Select
Loop
runAgain = MsgBox("Would you like to run the macro on another column?", vbYesNo)
If runAgain = vbNo Then
Cells(1, 1).Select
If screenRefresh = vbYes Then
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = True
End If
Exit Sub
ElseIf runAgain = vbYes Then
GoTo CopyAgain
End If
End Sub
Since it's a "general use" macro, I have prompts asking you which column to copy and if you want screen updating on. If you don't need these, let me know and I can remove/cut out some of the "fluff" and leave the main portion of the macro.
I have an excel sheet with around 200 work sheets each containing a list of products sold to a company.
I need to add
A total at the bottom of row D-G where the bottom can be a different value. I.E. E4
below the total a formula based on the total. I.E. if E4 (being the bottom of the above row) is below $999 the display text "samples", if between 1000-3000 then multiply E4 by 2%, 3001-7500 x 5% etc.
I need to be able to add it to the entire workbook easily using vba. Since I must do this to numerous ss it would literally save me 15-20 hours a month.
Edit:
So I have something that seems to be the right path.
Sub Split_Worksheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))
'Delete any sheet called "UniqueList"
'Turn off run time errors & delete alert
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
'Add a sheet called "UniqueList"
Worksheets.Add().Name = "UniqueList"
'Filter the Set range so only a unique list is created
With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
'Set a range variable to the unique list, less the heading.
Set rRange = .Range("A3", .Range("A65536").End(x2Up))
End With
On Error Resume Next
With wSheetStart
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete
'Add a sheet named as content of rCell
Worksheets.Add().Name = strText
'Copy the visible filtered range _
(default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With
With wSheetStart
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
Dim colm As Long, StartRow As Long
Dim EndCell As Range
Dim ws As Worksheet
StartRow = 3
For Each ws In Worksheets
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
If EndCell.Row > StartRow Then EndCell.Resize(, 4).Formula = "=SUM(R" & StartRow & "C:R[-1]C)"
Set EndCell = ws.Cells(Rows.Count, "D").End(xlUp)
If EndCell.Row >= 1000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.05))
Range(J3) = "5% Discount"
ElseIf EndCell.Row >= 3000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.1))
Range(J3) = "10% Discount"
End If
Next ws
End Sub'
Just need to figure out how to display the results and text to the right cells (J2 in this case)
I will supply the logic and all the references you need to put this one together; and will let you try to put it together on your own :). Come back for more help if needed.
You need to loop through all the worksheets in your workbook (Microsoft Tutorial)
You need to find the last row for the given columns (Online tutorial)
You need to use an IF statement to choose which formula to use (MSDN reference)
UPDATE
What's wrong with your code is this line :
Range(J2) = Formula = ((EndCell.Row) * (0.1))
What you're telling the computer is :
Multiply EndCell.Row by 0.1 (which has the number of the row below and to the right of the last cell in column C)
Compare Formula with the result previously obtained
Store the result of that logical expression at the range stored in variable J2
First of all, what you want is to put the result of the equation, and want to change J2 to "J2" so it gets the cell J2, instead of the what's contained in J2 (which has nothing at that point)
Also, you seem to say that you're not getting the right cells, maybe it is caused by this :
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
In that line, you're finding the last cell of column C, but then you select the cell below, and to the right of it.
There are so many things wrong with your code it's hard to say what's not working properly.
I have a quandary, and I don't know if it will work better using excel VBA or not. Thinking about it I believe VBA will work best, but I don't know how to make it work.
I have two pages in a workbook, one is the form, the other is the database, I want the pulldown menu from the form to populate the rest of the form. It does... what I want then is to be able to change the value of the form press submit, and the new data will overwrite the old data.
Is this possible?
Here is the link to the sheet I'm talking about.
http://dl.dropbox.com/u/3327208/Excel/Change.xlsx
Here is the script I am working with now...it takes the sheet, copies everything to a row takes that row, moves it to the NCMR Data tab and then clears the data on the new row from the original sheet.
This code technically could work, but what I need to do is make it use the same concept, but instead of creating a new row at the end of the sheet find the original line and replace the data from B to U in whatever row it was originally in.
I know it's possible, I just don't know how.
'Copy Ranges Variable
Dim c As Variant
'Paste Ranges Variable
Dim p As Range
'Setting Sheet
Set wsInt = Sheets("Form")
Set wsNDA = Sheets("Data")
Set p = wsInt.Range("A14")
With wsInt
c = Array(.Range("B11"))
End With
For i = LBound(c) To UBound(c)
p(i + 1).Value = c(i).Value
Next
With wsNDA
Dim Lastrow As Long
Lastrow = .Range("B" & Rows.Count).End(xlUp).Row + 1
wsInt.Rows("14").Copy
With .Rows(Lastrow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.Interior.Pattern = xlNone
End With
With .Range("A" & Lastrow)
If Lastrow = 3 Then
.Value = 1
Else
.Value = Val(wsNDA.Range("A" & Lastrow - 1).Value) + 1
End If
.NumberFormat = "0#######"
End With
End With
End Sub
I found this code:
Sub CopyTest()
Dim selrow As Range, rngToCopy As Range
With Worksheets("PD DB")
Set selrow = .Range("B:B").Find(.Range("BA1").Value)
'find the cell containing the value
Set rngToCopy = Union(selrow.Offset(0, 9), selrow.Offset(0, 12))
'use offset to define the ranges to be copied
rngToCopy.Copy Destination:=Worksheets("Edit Sheet").Range("B50")
'copy and paste (without Select)
End With
End Sub
As far as I can tell this will do what I want mostly, but I can't seem to figure out where to break it up to add it where I need to to make it work the way I want it to.
What I can tell is this, it will copy and paste, but I want to make sure it will paste the data into row it finds, and not overwrite the number of said row.
Can someone help make that possible with the two scripts I have here?
Not tested, but should get you started. I added a 3rd sheet (shtMap) to hold the mmapping between the cell addresses on your form and the column numbers on the "Data" sheet. Useful to name your sheets directly in the VB editor: select the sheet and set the name in the property grid.
*EDIT:*If you want to trigger the transfer on selecting a record id from a list in Range AG3 then place this code in the code module for that worksheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Static bProcessing As Boolean
Dim rng As Range
If bProcessing Then Exit Sub
Set rng = Target.Cells(1)
If Not Application.Intersect(rng, Me.Range("AG3")) Is Nothing Then
bProcessing = True
'this is where you call your macro to transfer the record
bProcessing = False
End If
End Sub
You could use something like this for the transfer:
Public Enum XferDirection
ToForm = 1
ToDataSheet = 2
End Enum
Sub FetchRecord()
TransferData XferDirection.ToForm
End Sub
Sub SaveRecord()
TransferData XferDirection.ToDataSheet
End Sub
Sub TransferData(Direction As XferDirection)
Dim rngMap As Range, rw As Range, f As Range, dataCell As Range
Dim formCell As Range, dataCol As Long, dataRow As Long
Dim sId As String
sId = shtForm.Range("AG3").Value
Set f = shtData.Columns(1).Find(sId, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
dataRow = f.Row
Else
'what do you want to do here?
' record doesn't exist on data sheet
MsgBox "Record '" & sId & "' not found on '" & shtForm.Name & "' !"
Exit Sub
End If
Set rngMap = shtMap.Range("A2:B10")
For Each rw In rngMap.Rows
'the cell on the edit form
Set formCell = shtForm.Range(rw.Cells(1).Value)
'column # on datasheet
Set dataCell = shtData.Cells(dataRow, rw.Cells(2).Value)
If Direction = XferDirection.ToDataSheet Then
dataCell.Value = formCell.Value
Else
formCell.Value = dataCell.Value
End If
Next rw
End Sub
Matt, there are two approaches I would take. The first is use find(), which returns a range object, then append ".row" so that you'll be able to modify the row on Sheet2 (wsNDA, I think). You may want to test that find() doesn't return Nothing.
Dim foundRow as Long
Dim foundRng as Range
set foundRng = wsNDA.find(wsInt.Range("B11").Value, ...)
If Not foundRng is Nothing Then
foundRow = foundRng.row
End If
'method without check: foundRow = wsNDA.find(wsInt.Range("B11").Value, ...).Row
The other is to use a Dictionary object. I'm not sure what you'd want for the key, but the item could be the row on the data sheet. When you make the change to what's on the form, check against the key and grab its item (the corresponding row) to determine where you need to replace the values.
This macro is to move records from a master sheet to other sheets based on criteria from column F.
A type mismatch error occurs in the "Termination" case where it is selecting the cell "B2".
I tried several different options, but each ends up with a different error.
Public Sub moveToSheet()
Sheets("Master").Select
' Find the last row of data
FinalRow = Range("E65000").End(xlUp).Row
'Loop through each row
For x = 2 To FinalRow
' Decide where to copy based on column F
ThisValue = Range("F" & x).Value
Select Case True
Case ThisValue = "Hiring "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Hiring").Select
Sheets("Hiring").Range("B2:W2500").Clear
Sheets("Hiring").Cells("B2").Select
ActiveSheet.Paste
Sheets("Master").Select
Case ThisValue = "Re-Hiring "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Hiring").Select
Sheets("Hiring").Range("B2:W2500").Clear
Sheets("Hiring").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Termination "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Terminations").Select
Sheets("Terminations").Range("B2:W2500").Clear
Sheets("Terminations").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Transfer "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Transfers").Select
Sheets("Transfers").Range("B2:W2500").Clear
Sheets("Transfers").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Name Change "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Name Changes").Select
Sheets("Name Changes").Range("B2:W2500").Clear
Sheets("Name Changes").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Address Change "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Address Changes").Select
Sheets("Address Changes").Range("B2:W2500").Clear
Sheets("Address Changes").Cells("B2").Select
ActiveSheet.Paste
Case Else
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("New Process").Select
Sheets("New Process").Range("B2:W2500").Clear
Sheets("New Process").Cells("B2").Select
ActiveSheet.Paste
End Select
Next x
End Sub
There are a couple problems, first, you need to use the syntax Range("B2").Select to select the cell. BUT, since you selected the entire row from the master sheet, you can't copy the entire row into B2, because the ranges aren't the same size, so you need to select the first cell (A2) instead.
So, the entire case statement should look like this:
Case ThisValue = "Termination "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Terminations").Activate
Range("A2").Select
ActiveSheet.Paste
There are a number of issues
No need to Select, use variables instead
Dim all your variables - help with debugging and learning
Some general good practice techniques will help
Here's a (partially) refactored version of your code
Public Sub moveToSheet()
Dim wb As Workbook
Dim shMaster As Worksheet, shHiring As Worksheet
Dim rngMaster As Range
Dim x As Long
Dim rw As Range
Set wb = ActiveWorkbook
Set shMaster = wb.Worksheets("Master")
Set shHiring = wb.Worksheets("Hiring")
' etc
' Find the data
x = shMaster.UsedRange.Count ' trick to reset used range
Set rngMaster = shMaster.UsedRange
'Loop through each row NOTE looping thru cells is SLOW. There are faster ways
For Each rw In rngMaster.Rows
' Decide where to copy based on column F
Select Case Trim$(rw.Cells(1, 6).Value) ' Is there really a space on the end?
Case "Hiring"
shHiring.[B2:W2500].Clear
rw.Copy shHiring.[B2]
' Case ' etc
End Select
Next rw
This is what I basically use to do exactly what you are talking about. I have a "master" sheet that is several thousand rows and a couple hundred columns. This basic version only searches in Column Y and then copies rows. Because other people use this, though, I have several template worksheets that I keep very hidden so you can edit that out if you don't want to use templates. I also can add additional search variables if needed and simply adding in another couple of lines is easy enough. So if you wanted to copy rows that match two variables then you'd define another variable Dim d as Range and Set d = shtMaster.Range("A1") or whatever column you wanted to search the second variable. Then on the If line change it to If c.Value = "XXX" and d.Value = "YYY" Then . Finally make sure you add an offset for the new variable with the c.offset (so it would have a line Set d = d.Offset(1,0) at the bottom with the other). It really has turned out to be pretty flexible for me.
Sub CreateDeptReport(Extras As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim arrColsToCopy
Dim c As Range, x As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error GoTo Err_Execute
arrColsToCopy = Array(1, 3, 4, 8, 25, 25, 21, 16, 17, 15, 31, 7) 'which columns to copy ?
Set shtMaster = ThisWorkbook.Sheets("MasterSheet")
Set c = shtMaster.Range("Y5") 'Start search in Column Y, Row 5
LCopyToRow = 10 'Start copying data to row 10 in Destination Sheet
While Len(c.Value) > 0
'If value in column Y equals defined value, copy to destination sheet
If c.Value = “XXX” Then
'only create the new sheet if any records are found
If shtRpt Is Nothing Then
'delete any existing sheet
On Error Resume Next
ThisWorkbook.Sheets("Destination").Delete
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtMaster
Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index + 1)
shtRpt.Name = "Destination" 'rename new sheet to Destination
‘Optional Information; can edit the next three lines out -
Range("F1").Value = "Department Name"
Range("F2").Value = "Department Head Name"
Range("B3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _
c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1 'next row
End If
Set c = c.Offset(1, 0)
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("A9").Select 'Position on cell A9
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Also, if you wanted then you could remove the screenupdating lines. As stupid as it sounds some people actually like to see excel working at it. With screenupdating off you don't get to see the destination sheet until the copying is completed, but with updating on the screen flickers like crazy because of it trying to refresh when each row is copied. Some of the older people in my office think that excel is broken when they can't see it happening so I keep screenupdating on most of the time. lol
Also, I like having the templates because all of my reports have quite a few formulas that need to be calculated after the information is broken down so I am able to keep all the formulas where I want them with a template. Then all I have to do is run the macro to pull from the master sheet and the report is ready to go without any further work.