I update sheets on a weekly basis, I import an external file (starting point) using the code below import selected Columns to sheet2- all is good.
Sub Copy_Specific_Columns_ToAnother_Sheet()
Sheets("Data").Range("C:C").Copy Sheets("Sheet2").Range("B:B")
Sheets("Data").Range("D:D").Copy Sheets("Sheet2").Range("C:C")
Sheets("Data").Range("B:B").Copy Sheets("Sheet2").Range("D:D")
Sheets("Data").Range("I:I").Copy Sheets("Sheet2").Range("E:E")
Sheets("Data").Range("K:K").Copy Sheets("Sheet2").Range("F:F")
Sheets("Data").Range("H:H").Copy Sheets("Sheet2").Range("G:G")
Sheets("Data").Range("J:J").Copy Sheets("Sheet2").Range("H:H")
Sheets("Data").Range("AF:AF").Copy Sheets("Sheet2").Range("I:I")
'Clean up sheet with formatting
ActiveSheet.UsedRange.Font.Size = 12
ActiveSheet.UsedRange.Font.Name = "Calibri"
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.UsedRange.EntireRow.AutoFit
Range("a1").EntireRow.RowHeight = 45
Range("a2").EntireRow.RowHeight = 30
End Sub
On sheet2 I create a unique identifier (non macro) and import the sheet 2 details to a Master sheet where I make edits from Columns K onwards.
The code below looks for the unique identifier and pull in new rows
** However when new rows are added it means that my notes from column L onwards are deleted every time i update.
Can the code below be modified so that new rows only update to a specific column (say upto K) leaving my additional notes and entries untouched.. ? ("A" column has the unique identifier, MACRO looks for changes and pulls in new rows)
Sub Update_Data()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim recRow As Long
Dim lastRow As Long
Dim fCell As Range
Dim i As Long
'Define our worksheets
Set wsSource = Worksheets("Sheet2")
Set wsDest = Worksheets("Master")
Application.ScreenUpdating = False
recRow = 1
With wsSource
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
'See if item is in Master sheet
Set fCell = wsDest.Range("A:A").Find(what:=.Cells(i, "A").Value, lookat:=xlWhole, MatchCase:=False)
If Not fCell Is Nothing Then
'Record is already in master sheet
recRow = fCell.Row
Else
'Need to move this to master sheet after last found record
.Cells(i, "A").EntireRow.Copy
wsDest.Cells(recRow + 1, "A").EntireRow.Insert
recRow = recRow + 1
End If
Next i
End With
'Code clean up
Application.CutCopyMode = False
Application.ScreenUpdating = True
'Clean up sheet with formatting
ActiveSheet.UsedRange.Font.Size = 12
ActiveSheet.UsedRange.Font.Name = "Calibri"
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.UsedRange.EntireRow.AutoFit
Range("a1").EntireRow.RowHeight = 45
Range("a2").EntireRow.RowHeight = 30
End Sub
Related
I'm creating a Calc document on the fly with vb6. I need to repeat 1 row and 1 column in every page when i print it.
This is the code:
Dim mPrintOptions(2) As Object
Dim OO_Dispatcher As Object
Set OO_Dispatcher = oServiceManager.createInstance("com.sun.star.frame.DispatchHelper")
Set mPrintOptions(0) = MakePropertyValue(oServiceManager, "PrintArea", "")
Set mPrintOptions(1) = MakePropertyValue(oServiceManager, "PrintRepeatRow", "$A$2")
Set mPrintOptions(2) = MakePropertyValue(oServiceManager, "PrintRepeatCol", "$A$1")
OO_Dispatcher.executeDispatch oDeskTop, ".uno:ChangePrintArea", "", 0, mPrintOptions
I've got this code making a macro in a saved document.
Service manager and Desktop objects are previously instanced. The document is being created fine, but when I send it to the printer it does not repeat the row and the column I specified above.
I've found my solution here:
https://wiki.openoffice.org/wiki/ES/Manuales/GuiaAOO/TemasAvanzados/Macros/StarBasic/TrabajandoConCalc/Imprimiendo
My code finally got like this:
Dim OO_TitulosR As Object
Dim OO_ActiveSheet As Object
Set OO_TitulosR = OO_Document.Bridge_getStruct("com.sun.star.table.CellRangeAddress")
Set OO_ActiveSheet = OO_Document.getCurrentController.getActiveSheet
OO_TitulosR.StartColumn = 0
OO_TitulosR.EndColumn = 0
OO_TitulosR.StartRow = 1
OO_TitulosR.EndRow = 1
OO_ActiveSheet.setTitleColumns OO_TitulosR
OO_ActiveSheet.setTitleRows OO_TitulosR
I have an Excel table in sheet1 in which column A:
Name of company Company 1 Company 2 Company
3 Company 1 Company 4 Company 1 Company
3
I want to extract a unique list of company names to sheet2 also in column A. I can only do this with help of a helper column if I dont have any blanks between company names but when I do have I get one more company which is a blank.
Also, I've researched but the example was for non-dynamic tables and so it doesn't work because I don't know the length of my column.
I want in Sheet2 Column A:
Name of company Company 1 Company 2 Company 3
Company 4
Looking for the solution that requires less computational power Excel or Excel-VBA. The final order which they appear in sheet2 don't really matter.
Using a slight modification to Recorder-generated code:
Sub Macro1()
Sheets("Sheet1").Range("A:A").Copy Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
With Sheets("Sheet2").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & Rows.Count) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A2:A" & Rows.Count)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sample Sheet1:
Sample Sheet2:
The sort removes the blanks.
EDIT#1:
If the original data in Sheet1 was derived from formulas, then using PasteSpecial will remove unwanted formula copying. There is also a final sweep for empty cells:
Sub Macro1_The_Sequel()
Dim rng As Range
Sheets("Sheet1").Range("A:A").Copy
Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets("Sheet2").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
Set rng = Sheets("Sheet2").Range("A2:A" & Rows.Count)
With Sheets("Sheet2").Sort
.SortFields.Clear
.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Call Kleanup
End Sub
Sub Kleanup()
Dim N As Long, i As Long
With Sheets("Sheet2")
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
If .Cells(i, "A").Value = "" Then
.Cells(i, "A").Delete shift:=xlUp
End If
Next i
End With
End Sub
All of these answers use VBA. The easiest way to do this is to use a pivot table.
First, select your data, including the header row, and go to Insert -> PivotTable:
Then you will get a dialog box. You don't need to select any of the options here, just click OK. This will create a new sheet with a blank pivot table. You then need to tell Excel what data you're looking for. In this case, you only want the Name of company in the Rows section. On the right-hand side of Excel you will see a new section named PivotTable Fields. In this section, simply click and drag the header to the Rows section:
This will give a result with just the unique names and an entry with (blank) at the bottom:
If you don't want to use the Pivot Table further, simply copy and paste the result rows you're interested in (in this case, the unique company names) into a new column or sheet to get just those without the pivot table attached. If you want to keep the pivot table, you can right click on Grand Total and remove that, as well as filter the list to remove the (blank) entry.
Either way, you now have your list of unique results without blanks and it didn't require any formulas or VBA, and it took relatively few resources to complete (far fewer than any VBA or formula solution).
Here's another method using Excel's built-in Remove Duplicates feature, and a programmed method to remove the blank lines:
EDIT
I have deleted the code using the above methodology as it takes too long to run. I have replaced it with a method that uses VBA's collection object to compile a unique list of companies.
The first method, on my machine, took about two seconds to run; the method below: about 0.02 seconds.
Sub RemoveDups()
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim rRes As Range
Dim I As Long, S As String
Dim vSrc As Variant, vRes() As Variant, COL As Collection
Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
Set rRes = wsDest.Cells(1, 1)
'Get the source data
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Collect unique list of companies
Set COL = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'Assume Row 1 is the header
S = CStr(Trim(vSrc(I, 1)))
If Len(S) > 0 Then COL.Add S, S
Next I
On Error GoTo 0
'Populate results array
ReDim vRes(0 To COL.Count, 1 To 1)
'Header
vRes(0, 1) = vSrc(1, 1)
'Companies
For I = 1 To COL.Count
vRes(I, 1) = COL(I)
Next I
'set results range
Set rRes = rRes.Resize(UBound(vRes, 1) + 1)
'Write the results
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
'Uncomment the below line if you want
'.Sort key1:=.Columns(1), order1:=xlAscending, MatchCase:=False, Header:=xlYes
End With
End Sub
NOTE: You wrote you didn't care about the order, but if you want to Sort the results, that added about 0.03 seconds to the routine.
With two sheets named 1 and 2
Inside sheet named: 1
+----+-----------------+
| | A |
+----+-----------------+
| 1 | Name of company |
| 2 | Company 1 |
| 3 | Company 2 |
| 4 | |
| 5 | Company 3 |
| 6 | Company 1 |
| 7 | |
| 8 | Company 4 |
| 9 | Company 1 |
| 10 | Company 3 |
+----+-----------------+
Result in sheet named: 2
+---+-----------------+
| | A |
+---+-----------------+
| 1 | Name of company |
| 2 | Company 1 |
| 3 | Company 2 |
| 4 | Company 3 |
| 5 | Company 4 |
+---+-----------------+
Use this code in a regular module:
Sub extractUni()
Dim objDic
Dim Cell
Dim Area As Range
Dim i
Dim Value
Set Area = Sheets("1").Range("A2:A10") 'this is where your data is located
Set objDic = CreateObject("Scripting.Dictionary") 'use a Dictonary!
For Each Cell In Area
If Not objDic.Exists(Cell.Value) Then
objDic.Add Cell.Value, Cell.Address
End If
Next
i = 2 '2 because the heading
For Each Value In objDic.Keys
If Not Value = Empty Then
Sheets("2").Cells(i, 1).Value = Value 'Store the data in column D below the heading
i = i + 1
End If
Next
End Sub
The code return the date unsorted, just the way data appears.
if you want a sorted list, just add this code before the las line:
Dim sht As Worksheet
Set sht = Sheets("2")
sht.Activate
With sht.Sort
.SetRange Range("A:A")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
This way the result will be always sorted.
(The subrutine would be like this)
Sub extractUni()
Dim objDic
Dim Cell
Dim Area As Range
Dim i
Dim Value
Set Area = Sheets("1").Range("A2:A10") 'this is where your data is located
Set objDic = CreateObject("Scripting.Dictionary") 'use a Dictonary!
For Each Cell In Area
If Not objDic.Exists(Cell.Value) Then
objDic.Add Cell.Value, Cell.Address
End If
Next
i = 2 '2 because the heading
For Each Value In objDic.Keys
If Not Value = Empty Then
Sheets("2").Cells(i, 1).Value = Value 'Store the data in column D below the heading
i = i + 1
End If
Next
Dim sht As Worksheet
Set sht = Sheets("2")
sht.Activate
With sht.Sort
.SetRange Range("A:A")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
If you have any question about the code, I will glad to explain.
I've been trying to implement some custom grouping with Infragistics xamDataGrid (Infragistics3.Wpf.DataPresenter.v9.1.Express), and pretty much cribbed the entire bit of code from the Infragistics site. I have two different date fields -- Due Date, and Reminder Date -- using GroupByEvaluator. Everything seemed well and good until I tried to add both fields to the GroupByArea.
What happens is this: the nested field groups according to the date of the parent field as opposed to grouping of the parent field. For example, when I drag the "Due Date" (parent) field to the GroupBy, it'll group these records by Due Date into four categories -- Due Next Year, Due This Year, Past Due, and Not Set. Perfect. But when I drag the "Reminder Date" field (nested) to the GroupBy, I'll find multiple labels of the same "Reminder Date" grouping nested under Due Date "Past Due".
I'm a newbie posting to SO, so I can't post an image. Instead, I'll type one out:
Past Due (Due Date)
Not Set (Reminder Date)
This Month (Reminder Date)
Not Set (Reminder Date)
Older (Reminder Date)
Not Set (Reminder Date)
etc....
With each subsequent nested grouping, the earliest Due Date (value of the parent grouping) is equal to or greater than the greatest Due Date of the previous grouping. It appears as though the "Past Due" collection is sorted by Due Date asc, and it's iterating through each record and creating a new nested group whenever there is a change in the nested label. So after 5 groupByRecords are given the label of "This Month", when the next "Not Set" groupByRecord pops up a new nested label is created instead of continuing to populate the existing one.
I'm having a related issue with sorting, which I suspect is what this entire issue hinges on. If the grid has been sorted according to Due Date, all of the sort by functionality of the other fields are constrained by the Due Dates. For example, sorting by client name will not sort all client name records into ascending or descending. Instead, it will sort, but it sort by Due Date first, and then Name.
Sorry I can't attach an image. Hopefully I explained the issue okay.
Thanks in advance! Code below:
Imports System.Collections.ObjectModel
Imports Infragistics.Windows.DataPresenter
Imports System.Windows
Imports System.Windows.Controls
Partial Public Class ManageEntities
Public Sub New()
' This call is required by the designer.
InitializeComponent()
' Add any initialization after the InitializeComponent() call.
Me.InitializeGroupByGrid()
End Sub
#Region "CustomGrouping"
'http://help.infragistics.com/Help/Doc/WPF/2012.2/CLR4.0/html/InfragisticsWPF4.DataPresenter.v12.2~Infragistics.Windows.DataPresenter.IGroupByEvaluator.html
Private Sub InitializeGroupByGrid()
For Each f In Me.SelectorGrid.FieldLayouts(0).Fields
If f.Name = "Form1DueDate" OrElse f.Name = "Form1LastReminderDate" Then
f.Settings.GroupByEvaluator = New CustomDateTimeEvaluator
' group by the data field
Dim fsd As FieldSortDescription = New FieldSortDescription()
fsd.Field = f
fsd.Direction = System.ComponentModel.ListSortDirection.Descending
Me.SelectorGrid.FieldLayouts(0).SortedFields.Add(fsd)
End If
Next
End Sub
#End Region
End Class
#Region "CustomDateTimeEvaluator"
'//20150918 - From infragistics: http://help.infragistics.com/Help/Doc/WPF/2013.1/CLR4.0/html/InfragisticsWPF4.DataPresenter.v13.1~Infragistics.Windows.DataPresenter.IGroupByEvaluator.html
Friend Class CustomDateTimeEvaluator
Implements IGroupByEvaluator
Private Const NotSet As String = "Not Set"
Private Const PastDue As String = "Past Due"
Private Const DueThisYear As String = "Due This Year"
Private Const DueNextYear As String = "Due Next Year"
Private Const RemindThisMonth As String = "This Month"
Private Const RemindLastMonth As String = "Last Month"
Private Const Older As String = "Older"
Dim targetDate As DateTime = Nothing
Public Function DoesGroupContainRecord(ByVal groupByRecord As GroupByRecord, ByVal record As DataRecord) As Boolean Implements IGroupByEvaluator.DoesGroupContainRecord
Dim cellValue As Object = record.GetCellValue(groupByRecord.GroupByField)
Dim desc As String = groupByRecord.Description
' handle null values specially
If cellValue Is Nothing Or TypeOf cellValue Is DBNull Then
Return desc = NotSet
End If
' if the value is not a date time, just group them together
If TypeOf cellValue Is DateTime = False Then
Return True
End If
Return desc = GetDateLabel(CType(cellValue, DateTime), groupByRecord.GroupByField.Name)
End Function
Public Function GetGroupByValue(ByVal groupByRecord As GroupByRecord, ByVal record As DataRecord) As Object Implements IGroupByEvaluator.GetGroupByValue
Dim cellValue As Object = record.GetCellValue(groupByRecord.GroupByField)
Dim desc As String = String.Empty
Dim targetDate As DateTime = DateTime.MinValue
If cellValue Is Nothing Or TypeOf cellValue Is DBNull Then
desc = NotSet
ElseIf TypeOf cellValue Is DateTime Then
targetDate = CType(cellValue, DateTime)
desc = GetDateLabel(targetDate, groupByRecord.GroupByField.Name)
End If
groupByRecord.Description = desc
Return targetDate
End Function
Public ReadOnly Property SortComparer() As System.Collections.IComparer Implements IGroupByEvaluator.SortComparer
Get
Return Nothing
End Get
End Property
Private Function GetDateLabel(ByVal dt As DateTime, ByVal fldName As String) As String
Dim d As String = NotSet
Dim comparison As Integer = Nothing
Dim currentYear As Integer = DatePart(DateInterval.Year, Now)
'//If no date, return NotSet
If dt.Ticks = 0 Then
Return d
End If
'//Group by fieldname name
If fldName.ToLower = "form1duedate" Then
'//Past Due includes any records where the Form 1 Due Date is less than July 1st of the current year
Dim cDDate As New DateTime(currentYear, 7, 1)
comparison = dt.Date.CompareTo(cDDate.Date)
If comparison = 0 Then
d = DueThisYear
ElseIf comparison < 0 Then
d = PastDue
ElseIf comparison > 0 Then
d = DueNextYear
Else
d = NotSet
End If
ElseIf fldName.ToLower = "form1lastreminderdate" Then
Dim currentMonth As Integer = DatePart(DateInterval.Month, Now)
Dim olderThanDate As New DateTime(currentYear, currentMonth - 1, 1)
If dt.Date.Year = currentYear AndAlso dt.Date.Month = currentMonth Then
d = RemindThisMonth
ElseIf dt.Date.Year = currentYear AndAlso dt.Date.Month = currentMonth - 1 Then
d = RemindLastMonth
ElseIf dt.Date < olderThanDate Then
d = Older
Else
d = NotSet
End If
End If
Return d
End Function
End Class
#End Region
I have a combobox filled with values. I want to select a value in the combo box and click the "Add" button to place this value into the some cells below. I can add one item to my list using the following code, but I want to be able to add multiple items. I feel that I am very close, I just need a few tweaks!
Private Sub CommandButtonAddItem_Click()
Dim ws As Worksheet
Dim box As ComboBox
Dim food As String
Dim num As Integer
num = 19
Set ws = Worksheets("sheet1")
Set box = ws.OLEObjects("ComboBox1").Object
food = box.Value
Worksheets("sheet1").Cells(num, 1) = food
If Worksheets("sheet1").Cells(num, 1) = " " Then
Worksheets("sheet1").Cells(num, 1) = food
num = num + 1
End If
End Sub
Try THIS!
If the "default" cell is already occupied, it'll keep going down untill it finds one that's not empty, to then put the value in that cell.
Private Sub CommandButtonAddItem_Click()
Dim ws As Worksheet
Dim box As ComboBox
Dim food As String
Dim num As Integer
num = 19
Set ws = Worksheets("sheet1")
Set box = ws.OLEObjects("ComboBox1").Object
food = box.Value
While Worksheets("sheet1").Cells(num, 1) <> ""
num = num + 1
Wend
Worksheets("sheet1").Cells(num, 1) = food
End If
End Sub
How do I do the following using DAO on a recordset
SELECT TOP 1 * FROM foo WHERE id = 10 ORDER BY timestamp DESC
Using SetCurrentIndex you can only use one index it seems otherwise using id and timestamp and selecting the first one would work.
I am by no means sure of what you want.
Dim rs As DAO.Recordset
Dim db As Database
Set db = CurrentDB
sSQL = "SELECT TOP 1 * FROM foo WHERE id = 10 ORDER BY timestamp DESC"
Set rs = db.OpenRecordset(sSQL)
Find does not work with all recordsets. This will work:
Set rs = CurrentDb.OpenRecordset("select * from table1")
rs.FindFirst "akey=1 and atext='b'"
If Not rs.EOF Then Debug.Print rs!AKey
This will not:
Set rs = CurrentDb.OpenRecordset("table1")
rs.FindFirst "akey=1 and atext='b'"