Export SQL Query to Excel File with multiple sheets - sql

I have the below query (thanks to stackoverflow) that will loop through a list of groups and give me the permissions the group will have for a category. In Linqpad I can export the result into one Excel sheet, but I was wondering if it was possible to export each group result in the loop to a separate sheet in the Excel file. I was going to try in C# first, but I was wondering if it can be done via SQL or Linqpad as well.
Also, Ad Hoc Distributed Queries are disabled on the server.
SELECT GroupId, Name
INTO #GroupTemp
FROM [Group]
DECLARE #Id INT
WHILE EXISTS (
SELECT * FROM #GroupTemp
)
BEGIN
SELECT TOP 1 #Id = GroupId
FROM #Temp
SELECT g.NAME AS 'GroupName'
,c.NAME AS 'CategoryName'
,c.CategoryId
,c.ParentCategoryId
,p.[Read]
,p.Edit
,p.[Delete]
,p.[Add]
,p.Share
,p.Admin
FROM GroupCategoryPermission p
INNER JOIN [Group] g ON p.GroupId = #Id
INNER JOIN Category c ON p.CategoryID = c.CategoryID
WHERE g.GroupId = #Id
DELETE #GroupTemp
WHERE GroupId = #Id
END

I just decided to use an Excel macro after I exported the query from Linqpad. My VBA is a little rusty and I have a couple of small issues that I need to work out (I'm sure there is an easier way than I did it), but this is okay for now. Basically, I searched for every row in column one with GroupName as the value. From there I stored those in an array and used the different in between each for each sheet to be added.
Option Explicit
Private Function Sleep()
Application.Wait Now + 1 / (24 * 60 * 60.0# * 2)
End Function
'Remove 1st row of Sheet 1 and blank rows from sheet
Private Function CheckEmpty()
On Error Resume Next
Worksheets(1).Select()
Columns("A").SpecialCells(xlBlanks).EntireRow.Delete()
Rows("1:1").Select()
Selection.Delete Shift:=xlUp
End Function
'Function to get the name of the group and name the sheet that name
Private Function NameSheet()
Dim groupName As String
groupName = ActiveSheet.Range("A2").Value
If Len(groupName) > 31 Then
groupName = Left(groupName, 31)
ActiveSheet.Name = groupName
Else
ActiveSheet.Name = groupName
End If
End Function
'This will format the sheet
Private Function FormatSheet()
Cells.Select()
With Selection
.WrapText = False
End With
Rows("1:1").Select()
Selection.Font.Bold = True
Cells.Select()
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Columns.AutoFit()
End With
End Function
'Main sub to separate groups into their own sheets
Sub SplitToSheets()
'Variables
Dim ws As Worksheet, rng As Range, cell As Range, findString As String
Dim counter As Long, numbers() As Long, lastRow As Long, firstRow As Long
'Clean sheet 1
Worksheets(1).Activate()
CheckEmpty()
FormatSheet()
'Set the range that we will be checking
firstRow = Rows("1:1").Row
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A" & firstRow & ":" & "A" & lastRow)
rng.Select()
'Set the counter so we loop through array
counter = 1
'Loop through array and store row numbers
For Each cell In rng
If cell.Value = "GroupName" Then
ReDim Preserve numbers(counter)
numbers(counter) = cell.Row
'Increase counter by 1
counter = counter + 1
End If
Next
'Separate groups to sheet using numbers array
'Variables
Dim inx As Long, rStart As Long, rEnd As Long, ind As Long
'Copy first group to new sheet on it's own (need to change logic to avoid separation, eventually)
rStart = numbers(1)
rEnd = numbers(2) - 1
Rows(rStart & ":" & rEnd).Select()
Selection.Copy()
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial(Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False)
NameSheet()
FormatSheet()
'Index Counter for looping through array
ind = 0
For inx = LBound(numbers) To UBound(numbers)
'Need to loop once and make sure the counter is greater than 1
If ind > 0 Then
'Revert to sheet 1
Worksheets(1).Select()
'Start row number
rStart = numbers(ind)
'End row number
rEnd = (numbers(ind) - numbers(ind - 1))
'Selection must start on second group
If rEnd > 1 Then
'Select range
Rows(rStart & ":" & rStart + rEnd).Select()
'Copy
Selection.Copy()
'Add next availble sheet
Sheets.Add After:=Sheets(Sheets.Count)
'Paste values
Selection.PasteSpecial(Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False)
'Set sheet name and rename to match group
NameSheet()
FormatSheet()
Sleep()
End If
End If
'Increase index by 1
ind = ind + 1
Next
'This deletes the main sheet that we no longer need
Application.DisplayAlerts = False
Worksheets(1).Delete()
Application.DisplayAlerts = True
Worksheets(1).Activate()
End Sub
'This macro will give option to seach for sheet
Sub GetSheet()
Dim SearchData As String
SearchData = InputBox("Enter 'exact' group name.")
If SearchData <> vbNullString Then
On Error Resume Next
Sheets(SearchData).Activate()
If Err.Number <> 0 Then MsgBox "Unable to find group named: " & SearchData
On Error GoTo 0
End If
End Sub

Related

VBA How to find a Specific Number based on Variable then Priority

I am trying to build a excel vba code that looks at data from three columns, takes the lowest 6 values of each variable (which there are four of) and also takes the adjacent column and pastes it in another sheet.
This is the input:
This is what I would like the output to be:
!
This is what the output actually is:
Actual Output
I stole a lot of this code from another post I saw, but it seems to be acting very randomly. I'm still not quite sure what the code is even doing, which is what makes it hard for me.
Any advice will help tremendously.
UPDATE: Using Ibo's fix on my sample data, it worked perfectly, however on my actual data it errored out. The reason I am doing this through a macro instead of manually is because it is a part of a much larger macro that is getting pieced together to predict production consumption of various raw materials and what needs to get staged.
Here's what happened:
Actual Input Data
Error 1004 Message and highlighted code
Output after failure
It looks like it got close, but didn't finish with the actual sort.
Sub TopPriorityPerPod()
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rngData As Range
Dim rngFound As Range
Dim rngUnqGroups As Range
Dim GroupCell As Range
Dim lCalc As XlCalculation
Dim aResults() As Variant
Dim aOriginal As Variant
Dim lNumTopEntries As Long
Dim i As Long, j As Long, k As Long
'Change to grab the top X number of entries per category'
lNumTopEntries = 6
Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output it'
Set rngData = wsData.Range("A2", wsData.Cells(Rows.Count, "C").End(xlUp))
aOriginal = rngData.Value 'Store original values so you can set them back later'
'Turn off calculation, events, and screenupdating'
'This allows code to run faster and prevents "screen flickering"'
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
'On Error GoTo CleanExit
With rngData
'.Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
.Sort .Resize(, 1).Offset(, 1), xlDescending, Header:=xlYes
End With
With rngData.Resize(, 1).Offset(, 1)
.AdvancedFilter xlFilterInPlace, , , True
Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.ShowAllData 'Remove the filter
ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 4)
i = 0
For Each GroupCell In rngUnqGroups
Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
k = 0
If Not rngFound Is Nothing Then
For j = i + 1 To i + lNumTopEntries
If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
k = k + 1
aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
aResults(j, 2) = rngFound.Offset(j - i - 1).Value
aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
aResults(j, 4) = rngFound.Offset(j - i - 1, 2).Value
End If
Next j
i = i + k
End If
Next GroupCell
End With
'Output results'
wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
CleanExit:
'Turn calculation, events, and screenupdating back on'
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number <> 0 Then
'There was an error, show the error'
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
'Put data back the way it was
rngData.Value = aOriginal
End Sub
You can have different approaches. In this method I copy the data to another sheet called Result, then insert a table, sort the columns and then collect the range where the rows are more than 6 and then delete the whole rows at once, it will be really fast:
Sub Main()
Dim i As Long
Dim rng As Range
Dim tbl As ListObject
Dim WS As Worksheet
Dim WS2 As Worksheet
Set WS = Worksheets("Sheet1") 'this is where you have the data
Set WS2 = Worksheets.Add
WS2.Name = "Result"
WS.Range("A1").CurrentRegion.Copy
WS2.Paste
'sort priority column first
WS2.ListObjects.Add(xlSrcRange, Range(WS2.UsedRange.Address), , xlYes).Name = "Table1"
Set tbl = WS2.ListObjects("Table1")
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Priority]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sort station column
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Station]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove any row exceeding 6th occurrence
Dim cnt As Integer
For i = 1 To tbl.ListRows.Count - 1
If tbl.ListColumns("Station").DataBodyRange(i, 1).Value = tbl.ListColumns("Station").DataBodyRange(i + 1, 1).Value Then
cnt = cnt + 1
If cnt >= 6 Then
If rng Is Nothing Then
Set rng = tbl.ListColumns("Station").DataBodyRange(i + 1, 1)
Else
Set rng = Application.Union(rng, tbl.ListColumns("Station").DataBodyRange(i + 1, 1))
End If
End If
Else
cnt = 0 'reset the counter
End If
Next i
'remove rows
If Not rng Is Nothing Then
tbl.Unlist
rng.EntireRow.Delete
End If
End Sub
So I've put something together for you that should get you most of the way there.
You'll need to do a few things to get this working for your file (learning opportunity!):
(1) Adjust the ranges as relevant to your file
(2) Print the output to the worksheet. As of right now the output is being printed to the immediate debug window.
What this code will do is sort out each letters values into a collection named after the letters.
From there we convert the collection to an array. We then utilize the "Small" worksheet function on the arrays, and loop through the 6 lowest values.
Happy to help with any further questions you may have!
Public Function CollectionToArray(myCol As Collection) As Variant
'Thanks to user Vityata for this converter function (https://stackoverflow.com/users/5448626/vityata).
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.Count - 1)
For cnt = 0 To myCol.Count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
Sub ArraySort()
Dim Cell As Range
Dim KeyMultiple As String
Dim collA As New Collection
Dim collB As New Collection
Dim collC As New Collection
Dim collD As New Collection
Dim Rng_Col As Range
Set Rng_Col = Sheets("Sheet1").Range("A2:A22")
Dim GroupByArr As Variant
GroupByArr = Array("A", "B", "C")
Counter = 0
For i = 1 To 22
If Cells(i, 1).Value = "A" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collA.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "B" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collB.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "C" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collC.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "D" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collD.Add Item:=Cells(i, 2), Key:=KeyMultiple
End If
Next i
For i = 1 To 6
Debug.Print WorksheetFunction.Small(CollectionToArray(collA), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collB), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collC), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collD), i)
Next i
Set collA = New Collection
Set collB = New Collection
Set collC = New Collection
Set collD = New Collection
End Sub
here's a solution exploiting Array, Dictionary and SortedList object, that shuold be quite fast:
Option Explicit
Sub main()
Dim wsData As Worksheet: Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Dim wsDest As Worksheet: Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output
Dim stations As Variant, station As Variant
Dim iStation As Long
Dim stationsList As Object: Set stationsList = CreateObject("Scripting.Dictionary") ' use dictionary to collect unique station values
With wsData
stations = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value
For iStation = 1 To UBound(stations, 1)
stationsList(stations(iStation, 1)) = stationsList(stations(iStation, 1)) & stations(iStation, 2) & "|" & stations(iStation, 3) & " " ' update current station priorities list and orders
Next
End With
Dim prioritiesAndOrders As Variant, priorityAndOrder As Variant, priority As Variant, order As Variant
Dim iPriority As Long, nPriorities As Long
For Each station In stationsList.Keys ' loop through unique stations
prioritiesAndOrders = Split(Trim(stationsList(station)), " ") ' get current station priorities and corresponding orders list
With CreateObject("System.Collections.SortedList") ' cerate and reference a sortedList object (it stores keys in ascending order)
For Each priorityAndOrder In prioritiesAndOrders ' loop through current station priorities and corresponding orders list
priority = Split(priorityAndOrder, "|")(0) ' get current priority
order = Split(priorityAndOrder, "|")(1) 'get current priority corresponding order
.Add priority, order ' store current priority as "key" of SortedList object and its corresponding order as its value
Next
nPriorities = WorksheetFunction.Min(.Count - 1, 5) ' define the current station number of priorities to manage
ReDim results(1 To nPriorities + 1, 1 To 3) As Variant ' size results array accordingly
For iPriority = 0 To nPriorities ' loop through current station sorted priorities (and corresponding orders) and fill results array with current station in column 1, its priorities in column 2 and priority corresponding order in column 3
results(iPriority + 1, 1) = station
results(iPriority + 1, 2) = .GetKey(iPriority)
results(iPriority + 1, 3) = .GetValueList()(iPriority)
Next
End With
wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1).Resize(nPriorities + 1, 3).Value = results ' write current station sorted priorities
Next
End Sub

Nested Loop Excel VBA

I need your help in nexted VBA loop. I have some data in two columns and blank rows between rows. This macro loop through a column and find out if it contain certain character. If it' blank then I want it to move to next row. If it contain "Den", then select a specific worksheet ("D-Temp") else select ("M-Temp").
After selecting right Worksheet, it need to fill up text boxs with data from 2nd column as per Row no. The code I have created so far is
Sub Template()
Dim j As Long
Dim c As Range, t As Range
Dim ws As String
j = 5
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value = "" Then
Next ' `Not getting how to jump to next one`
ElseIf c.Value = "DEN" Then
ws = "D-Temp"
Else
ws = "M-Temp"
End If
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
Next
End With
Any help ??
Below is the sample Data I have :
Type Name 1 Name2
DEN Suyi Nick
'Blank row'
PX Mac Cruise
I want macro to Identify Type & select template worksheet (D or M) as per that and fill textboxes on that template with Name 1 & Name2 respectively.
may be you're after this:
Option Explicit
Sub Template()
Dim c As Range
With Sheets("Sample")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced sheet column C not empty cells form row 3 down to last not empty one
Worksheets(IIf(c.Value = "DEN", "D-Temp", "M-Temp")).Copy after:=Sheets(Sheets.Count) ' create copy of proper template: it'll be the currently "active" sheet
With ActiveSheet ' reference currently "active" sheet
.Shapes("Textbox 1").TextFrame.Characters.Text = c.Offset(, 7).Value ' fill referenced sheet "TextBox 1" shape text with current cell (i.e. 'c') offset 7 columns (i.e. column "P") value
.Shapes("Textbox 2").TextFrame.Characters.Text = c.Offset(, 6).Value ' fill referenced sheet "TextBox 2" shape text with current cell (i.e. 'c') offset 6 columns (i.e. column "O") value
End With
Next
End With
End Sub
If I'm not mis-understanding your current nesting...
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value <> "" Then
If c.Value = "DEN" Then
ws = "D-Temp"
Else
ws = "M-Temp"
End If
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
End if 'not blank
Next
End With
If I understand your question, correctly, you need to change your if/then logic slightly:
Sub Template()
Dim j As Long
Dim c As Range, t As Range
Dim ws As String
j = 5
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value <> "" Then
If c.Value = "DEN" Then
ws = "D-Temp"
Exit For
Else
ws = "M-Temp"
Exit For
End If
End If
Next
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
End With
End Sub
You might want to add code to make sure that ws is set to something (not all columns were blank).

Is there any fast way to copy Duplicate rows(next to each other) from a Sheet to another by analyzing multiple columns in Excel VBA?

I want to copy duplicate rows from a sheet to another by analyzing multiple columns in excel, I can do it by applying Nested For loops to compare multiple columns but number of rows in my sheet is around 6000. So if I apply nested For loop to compare rows by analyzing 2 columns it requires around 17991001 iterations, which slows down my System. Is there any fast way to do that???
my Function is
Sub findDuplicates(ByVal sheet As Worksheet, name As String, ByRef row As Integer, ByVal Sheet2 As Worksheet)
Dim i As Integer
Dim numRow As Integer
'Dim matchFound As Long
'Dim myRange1 As Range
'Dim myRange2 As Range
numRow = sheet.Range("J2", sheet.Range("J2").End(xlDown)).Rows.Count
With Sheet2
Range(Cells(row, "A"), Cells(row, "N")).MergeCells = True
With Cells(row, "A")
.Font.name = "Bell MT"
.Font.FontStyle = "Bold Italic"
.Font.Size = 20
.Font.Color = RGB(255, 99, 71)
.Value = "Multiple Forms Found in " & name & " for single household"
End With
row = row + 1
End With
For i = 1 To numRow + 1
'matchFound
'If i <> matchFound Then
sheet.Rows(i).Copy Sheet2.Rows(row)
row = row + 1
'sheet.Rows(matchFound).Copy Sheet2.Rows(row)
'row = row + 1
'End If
Next i
End Sub
Note - I added some comments to make you understand what I want to do.
The Summery of my function is to take two sheets and check the J and K columns of sheet 1, If two rows found same J and K column's value then both rows are copied to sheet2 (next to each other)
Try this. Modified from Siddharth Rout's answer here.
Private Sub CommandButton2_Click()
Dim col As New Collection
Dim SourceSheet As Worksheet
Dim DestSheet As Worksheet
Dim i As Long
Dim lLastRow As Long
Application.ScreenUpdating = False
Set SourceSheet = ThisWorkbook.Sheets("Sheet1")
Set DestSheet = Worksheets("Sheet2")
lLastRow = SourceSheet.Cells(Rows.Count, 10).End(xlUp).row
DestSheetLastRow = 1
With SourceSheet
For i = 1 To lLastRow
On Error Resume Next
col.Add i, CStr(.Range("J" & i).Value) 'Add elements to collection
If Err.Number <> 0 Then 'If element already present
TheVal = CStr(SourceSheet.Range("J" & i).Value) 'Get the duplicate value
TheIndex = col(TheVal) 'Get the original position of duplicate value in the collection (i.e., the row)
If (.Cells(i, 11).Value = .Cells(TheIndex, 11).Value) Then 'Check the other column (K). If same value...
SourceSheet.Range(Cells(TheIndex, 1), Cells(TheIndex, 20)).Copy DestSheet.Cells(DestSheetLastRow, 1) 'Set your range according to your needs. 20 columns in this example
SourceSheet.Range(Cells(i, 1), Cells(i, 20)).Copy DestSheet.Cells(DestSheetLastRow, 21)
DestSheetLastRow = DestSheetLastRow + 1
Err.Clear
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Finally, This Works for me
Sub findDuplicates(ByVal sheet As Worksheet, name As String, ByRef row As Integer, ByVal Sheet2 As Worksheet)
Dim i As Integer
Dim j As Integer
Dim numRow As Integer
Dim count As Integer
Dim myRange1 As Range
Dim myRange2 As Range
Dim myRange3 As Range
Set myRange1 = sheet.Range("J2", sheet.Range("J2").End(xlDown)).Rows
Set myRange2 = sheet.Range("K2", sheet.Range("K2").End(xlDown)).Rows
numRow = sheet.Range("J2", sheet.Range("J2").End(xlDown)).Rows.count
With Sheet2
Range(Cells(row, "A"), Cells(row, "N")).MergeCells = True
With Cells(row, "A")
.Font.name = "Bell MT"
.Font.FontStyle = "Bold Italic"
.Font.Size = 20
.Font.Color = RGB(255, 99, 71)
.Value = "Multiple Forms Found in " & name & " for single household"
End With
sheet.Rows(1).Copy .Rows(row + 1)
.Rows(row + 1).WrapText = False
row = row + 2
End With
j = row
For i = 1 To numRow + 1
count = WorksheetFunction.CountIfs(myRange1, sheet.Cells(i, "J"), myRange2, sheet.Cells(i, "K"))
If count > 1 Then
sheet.Rows(i).Copy Sheet2.Rows(row)
row = row + 1
End If
Next i
Set myRange3 = Sheet2.Range(Cells(j, 1), Cells(row - 1, 192))
With Sheet2.Sort
.SortFields.Add Key:=Range("J1"), Order:=xlAscending
.SortFields.Add Key:=Range("K1"), Order:=xlAscending
.SetRange myRange3
.Header = xlNo
.Orientation = xlTopToBottom
.Apply
End With
End Sub

VBA code to shift columns over and maintain formula

Hi guys so this is my code:
Sub Biz1_Shift_OnePeriod()
'Shift all values one period to the left
'Message Box Question
Ans = MsgBox("Update data by one year?", vbYesNo + vbQuestion, "Data Update")
If Ans = vbNo Then Exit Sub
'Turn off screen updating & calculation to make code run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim CopyFromWks As Worksheet
Dim CopyToWks As Worksheet
Dim j As Integer
Dim C As Range
'---------------------------------------------------------------------
'Business - Balance Sheet
'
'
'Set the worksheet
Sheets("Balance Sheet").Select
Range("A2").Select
Set CopyToWks = Sheets("Balance Sheet")
Set CopyFromWks = Sheets("Balance Sheet")
'
'Copy data loop from 2nd Historical to 3rd Historical
Set Copyfrom = CopyFromWks.Range("L:L")
Set Copyto = CopyToWks.Range("I:I")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = Copyfrom(j, i).Value
End If
Next
Next
Next
'
'Copy data loop from 1st Historical to 2nd Historical
Set Copyfrom = CopyFromWks.Range("O:O")
Set Copyto = CopyToWks.Range("L:L")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = Copyfrom(j, i).Value
End If
Next
Next
Next
'
'Set Historical Yr 1 to Zero
Set Copyto = CopyToWks.Range("O:O")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = 0
End If
Next
Next
Next
'
'Set Current equal to Zero
Set Copyto = CopyToWks.Range("R:R")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyto.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = 0
End If
Next
Next
Next
What I want to do is shift my columns over to the left. I thought a copy paste method would do and for now I have the last column set to 0. However, I need the last column to retain all its formulas, but have it not be pulling from any data source. I came up with an idea to create another column that would be hidden and storing all the formula there and have that shift over when the macro is triggered. I wanted to ask you guys if there is a better way of going about this and help brainstorm a little bit.
Try
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Using the following code it populates all cells in the table that are blank

I have the following code and it works great except for one thing when it is used it finds every blank field in the table and inserts the value of the field above it. I only need it to fill the fields above the rows that were inserted by the code.
Sub ERCACMPCleanup()
'Cleans ERCA_CMP Worksheet and creates extra records for comma delimited
Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
Const Delimiter As String = ", "
Const DelimitedColumn As String = "A"
Const TableColumns As String = "A:O"
Const StartRow As Long = 2
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets("ERCA_CMP").Visible = True
ActiveWorkbook.Worksheets("ERCA_CMP").Activate
LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
For X = LastRow To StartRow Step -1
Data = Split(Cells(X, DelimitedColumn), Delimiter)
If UBound(Data) > 0 Then
Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
End If
If Len(Cells(X, DelimitedColumn)) Then
Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
End If
Next
**LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
On Error Resume Next
Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
If Err.Number = 0 Then
Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
Table.Value = Table.Value
End If
On Error GoTo 0**
End Sub
The issue is in the last few rows this code needs to only fill the blanks in the inserted rows not all blank fields in the table.
Any help is greatly appreciated.
Modified the code to check if all cells in B:0 are null. I think intersect would not be correct in this case as you don't want to apply this to all the cells.
Note 1: There would be better solution than this too as I'm not familiar with complete VBA
Note 2: If you put Application.ScreenUpdating = False you should set it to True at the end of the program too.
Sub ERCACMPCleanup()
'Cleans ERCA_CMP Worksheet and creates extra records for comma delimited
Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
Dim flgval As Boolean, rcntr As Integer, ccntr As Integer, rownum As Integer
Const Delimiter As String = ", "
Const DelimitedColumn As String = "A"
Const TableColumns As String = "A:O"
Const StartRow As Long = 2
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets("ERCA_CMP").Visible = True
ActiveWorkbook.Worksheets("ERCA_CMP").Activate
LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
For X = LastRow To StartRow Step -1
Data = Split(Cells(X, DelimitedColumn), Delimiter)
If UBound(Data) > 0 Then
Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
End If
If Len(Cells(X, DelimitedColumn)) Then
Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
End If
Next
'Modification Start for the question
'flgval turns true if cells B:O are not empty
flgval = False
Range("A1").Activate
For rcntr = 0 To LastRow - 1
For ccntr = 1 To 14
If ActiveCell.Offset(0, ccntr).Value <> "" Then
flgval = True
Exit For
End If
Next
If flgval = False Then
For ccntr = 1 To 14
ActiveCell.Offset(0, ccntr).FormulaR1C1 = "=R[-1]C"
Next
Else
flgval = False
End If
ActiveCell.Offset(1, 0).Activate
Next
'**LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
'On Error Resume Next
'Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(rownum - StartRow))
'If Err.Number = 0 Then
' Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
' Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
' Table.Value = Table.Value
'End If
'On Error GoTo 0**
Application.ScreenUpdating = True
End Sub