I have a table (Sheet2) with a list of unique project IDs, this list is based on an advanced filter, and is updated regularly, adding new projects, while a lot of the old projects still appear on the list.
I have another table (Sheet1), where unique projects (that exist in Table A, but not in table B) have to be copied to the last row(+1) of the table. Users will then input information about the projects, so it is important that the information already in the table does not shift around when new projects are loaded.
I have this code, and on the surface it does the job. But i think it may a bit clunky, and users have experienced that when the macro is run, sometimes duplicates are added to table B. From the code, I don't see how this is possible, and i haven't been able to replicate it.
Can anyone take a look at the code and see if there's an issue? Or think of a simpler way to do what I'm looking for? I am new to VBA, and the code I've written has been lifted and adapted from elsewhere through trial and error, so I'm having a hard time figuring out if theres something wrong with it :-)
Project IDs are in column A, and I'm trying to copy values A:D from Sheet2 to Sheet1
Option Explicit
Public Sub Projecs()
Dim Source As Long
Dim Dest As Long
Dim Count As Long
Source = 1
Dest = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Do Until Sheet2.Cells(Source, "A") = ""
If Sheet1.Range("A:A").Find(what:=Sheet2.Cells(Source, "A"), lookat:=xlWhole) Is Nothing Then
Dest = Dest + 1
Sheet1.Range(Sheet1.Cells(Dest, "A"), Sheet1.Cells(Dest, "D")).Value = _
Sheet2.Range(Sheet2.Cells(Source, "A"), Sheet2.Cells(Source, "D")).Value
Count = Count + 1
End If
Source = Source + 1
Loop
MsgBox "Copied " & Count & " projects to production"
End Sub
Thank you for your help!
Related
Okay, so don't mind the title, I had trouble summarizing my current issue. But first here is what I am trying to do :
I have three sheets, first one is containing a list of Attributes, the second a list of Categories and the third a cross table associating Attributes and Categories.
The code i'm working on is quite straightforward : when selecting one or many attributes (or categories) using checkboxes and executing the macro, the code will look for ticked checkboxes, get the ID associated to the selected attributes (or categories), then delete the line in the attribute (or category) worksheet and also in the cross table.
The sheets looks like that :
*Attribute Sheet*
*Category Sheet*
*Cross Table*
And here is my code :
Sub Delete_Selection()
Dim Wb As Workbook: Set Wb = Workbooks("DataBase WIP.xlsm")
Dim Sws As Worksheet: Set Sws = ActiveSheet
Dim CrossWs As Worksheet: Set CrossWs = Sheet6
Dim Cb As CheckBox
Dim Checking As Range
Dim LastRow As Long: LastRow = Sws.Cells(Sws.Rows.Count, "B").End(xlUp).Row
Dim CRow As Long, IDColumn As Long, IDRow As Long
Dim CID As String
IDColumn = Sws.Cells.Find(What:="ID", LookAt:=xlWhole).Column 'Look for the ID column in the current sheet
MsgBox (IDColumn) 'Debug purpose
For Each Cb In Sws.Checkboxes
If (Cb.Value = 1) Then 'If checkbox is ticked, proceed
CRow = Range(Cb.LinkedCell).Row 'Get the row number of the checkbox
MsgBox (CRow) 'Debug purpose
CID = Cells(CRow, IDColumn).Value 'Get the ID value
Rows(CRow).Delete Shift:=xlUp 'Delete the row
Cb.Delete 'Delete the checkbox
If (ActiveSheet.CodeName = "Sheet2") Then 'If attributes are being deleted, proceed
MsgBox (CID) 'Debug Purpose
IDRow = CrossWs.Cells.Find(What:=CID, LookAt:=xlWhole).Row 'Find the corresponding row in the cross table
CrossWs.Rows(IDRow).Delete Shift:=xlUp 'Delete it
End If
If (ActiveSheet.CodeName = "Sheet5") Then 'If categories are being deleted, proceed
MsgBox (CID) 'Debug Purpose
IDColumn = CrossWs.Cells.Find(What:=CID, LookAt:=xlWhole).Column 'Find the corresponding column in the cross table
CrossWs.Columns(IDColumn).Delete Shift:=xlToLeft 'Delete it
End If
End If
Next
End Sub
The issue :
The code works perfectly fine when selecting and deleting multiple attributes
The code works when selecting and deleting one category
BUT : when selecting multiple categories and running the deletion code, it deletes them all in the category sheet but it only delete one corresponding column in the cross table.
Example : if I want to delete the beef and beans category, I select them using the checkboxes then press the button, in the category sheet they're all successfully deleted (yay !) but only the beef column will be deleted in the crosstable.
So to figure out why, I decided to print the relevant variables, what is happening in the previous example is the following :
IDColumn = 1 which is normal
CRow = 10 fine too
CID = DOC9 expected
Then
IDColumn = 1 Wasn't supposed to change
Crow = 10 The rows have been shifted up to fill the gap so totally normal
CID = "" And that's where my issue is.
Despite looking at the right cell, CID don't get the value contained in it and I don't understand why at all.
Important precision, the attribute sheet is perfectly normal while the category sheet contains a Table ! I think that's where the issue lies but I couldn't find anything useful on the Internet.
And I don't understand why the program would be able the read the value of a cell the first time and then doesn't. I may have missed something obvious so I apologize if its the case but any help would be greatly appreciated !
Edit 1 : It has nothing to do with the Categories being in a table, I wrote a similar code but I ran into the exact same issue even without looking at a Table. I still don't know what's happening.
I found a workaround by first reading all my ID's and storing them into an array and then looping through my array to modify my cross table. I will probably do the same for my current issue.
Okay, I found the problem.
Once again I wasted a lot of time because of a stupid mistake.
When I was deleting a category, I needed to find the column linked to that category in my cross table, and I stupidly used the same variable referring to the ID column of my Category sheet (i.e. "IDColumn"), changing its value and therefore when reading the next ID, my code was looking in the wrong cell.
Thanks to anyone who have tried to help me ! I will hopefully not make a fool of myself next time ahah.
I'm trying to create a macro that categorizes my bank statements. But I'm not that proficient with VBA and I don't have a clear idea on how to tackle this problem.
It goes as follows:
I import a CSV into excel which I delimit into columns. This part is working now. Looking like this:
I want to be able to cut the relevant transactions and paste them to their respective tables. So municipality goes to the municipality table, bank goes to the bank table, energy goes to the energy table.
I am using different banks so therefore I have different CSVs. So the layout changes all the time. Some banks have Date in column A, some in column C. So the ranges should always be dynamic.
I created a Key Table that has all the relevant variables that can match with the relevant transactions looking like this:
The Key can be found somewhere in the Imported range. Like I said before, the location of the key changes depending on the bank. I want to be able to say the following.
If key x matches somewhere in import_range then cut "Name, Description and Amount from the same row into another table on another worksheet which correlates to the Type of the Key.
So from the image, if key 21315665 is found (as a string?) somewhere in import_range then I want the Name (internet provider), Description and Amount that correlates to that same row cut and pasted into a different (already existing) table, adding the information to the bottom of said table.
I hope anyone can help me out with this. I have a working code that I wrote but it is a pain to update and very basic. It just compares if key x is in cell z and if so copies it.
Dim myString As String
Dim incassovalue As String
Dim lastrow As Range
Dim Table As ListObject
Set Table = Sheets("Transactions").ListObjects("Energy")
Import_last_row = Sheets("Import").Range("A" & Rows.Count).End(xlUp).Row
For i = Import_last_row To 6 Step -1
'Energy
myString = Sheets("Import").Cells(i, 9).Value
incassovalue = Sheets("Incasso").Cells(5, 5).Value
If InStr(myString, incassovalue) > 0 Then
If Table.ListRows.Count > 0 Then
Set lastrow = Table.ListRows(Table.ListRows.Count).Range
If Application.CountBlank(lastrow) < lastrow.Columns.Count Then
Table.ListRows.Add
End If
End If
If Table.ListRows.Count = 0 Then
Table.ListRows.Add Position:=1
Set lastrow = Table.ListRows(1).Range
Else
Set lastrow = Table.ListRows(Table.ListRows.Count).Range
End If
Sheets("Import").Cells(i, 1).Copy Table.Range([Energy].Rows.Count + 1, 1)
Sheets("Import").Cells(i, 2).Copy Table.Range([Energy].Rows.Count + 1, 2)
Sheets("Import").Cells(i, 7).Copy Table.Range([Energy].Rows.Count + 1, 3)
Sheets("Import").Cells(i, 1).EntireRow.Delete
End If
Next i
Now this code kind of works, but it isnt dynamic at all, I would have to make a 1000 conditions like this to make it work for all my bank accounts. I hope someone here can help me out, or send me in the right direction.
first of all I've read many topics but none has my solution.
I have a data of 4 columns and N Rows (as N is unknown number).
Here is a sample:
When a new row entered I want it to automatically create new sheet has the name which is written in title column of that row (for the first row, create sheet with name "M")
also copy all data in row M to the new sheet
i know there is a way
=<SheetName>!<cell> but it isn't really helps if i have for example 1000 columns,
i have to create 1000 sheet then copy 1000 times!!
that's all, thanks in advance.
also feel free to use any methods (such as VBA).
I think this could be messy especially if you end up with a lot of Data. The code below will allow you to run a Macro that will quickly create sheets based on the data. This macro will only work once but it does the job
Sub CopyRowsToSheet()
' Variables needed for the formula
Dim NofRows As Long
Dim i As Long
Dim iActive As Boolean
' Counting the number of Rows in the active sheet
With ActiveSheet
NofRows = .Range("A" & Rows.Count).End(xlUp).Row
' Cycling through the number of rows on the active sheet
' we have set i = 2 as there is a header on the first page. If there is no header then set i = 1
For i = 2 To NofRows
' Creating the new sheet
Worksheets.Add(, Sheets(Sheets.Count)).Name = "Row " & i
' Copy Data to new sheet
.Rows(i).Copy Sheets("Row " & i).Range("A1:D1")
Next i
End With
End Sub
Apologies not 100% sure how to make this automatic but if I find a way i will add it here for you
This is a very strangely specific need, and the last thing I need to complete my suite of new macros.
Note: The '---' at the top of the sheet is there to represent several months of the same report going back in time
As you can see in the image linked above, I have two highlighted sections. I need to make column G the sum of E and F from the previous report's numbers. Because there is a new set of data added every day, I can't reference specific cells and it must be dynamic. The larger problem here is that my number of customers will change every so often. It will only go up and it will always be in the same order; even if a lose a customer they stay on the report in the same spot.
My only theories on how to get this done are:
Find the second to last instance of customer A and define a rng based on the offset cells to the right. My problem with this is that—to my understanding—even filling that formula all the way down will just give me the one value.
Adding =SUM((INDIRECT(ADDRESS(ROW()-5,COLUMN()-2))):(INDIRECT(ADDRESS(ROW()-5,COLUMN()-1)))) to the blank cells. My problem with this is that the -5 in the offset is able to change, and even defining it by the number of blank cells will cause a mistake the first time a new customer comes on.
Any insight would be very much appreciated. And please let me know if you have any clarifying questions; I'm happy to answer/edit the original post as needed.
It can probably be optimised further by actually pre-calculating the range, but the naive version would be:
=SUMIFS([Outstanding Mail],[Date],LOOKUP([#Date]-1,[Date]),[Customer],[#Customer])
+SUMIFS([Outstanding Faxes],[Date],LOOKUP([#Date]-1,[Date]),[Customer],[#Customer])
Which relies on the fact that your dates are sorted, and that LOOKUP returns the last value that is not greater than the supplied value, so the [#Date]-1 makes it look up the biggest date that is less than the provided date. Will not work on an unsorted range.
#Gserg got an answer ahead of me, and his solution is one good elegant line, although i think it goes on the assumption there will be items every day there (if I`m not wrong?), and your screenshot suggest they may not be consecutive days all the time.
If you are still looking at a VBA solution as well, I would do something like this:
Option Explicit
Sub addOffsetFormula()
'Declare and set your workbook
Dim wb As Workbook: Set wb = ActiveWorkbook
'Declare and set your spreadsheet
Dim shData As Worksheet: Set shData = wb.Worksheets("Data")
'Set your last row/column for a dynamic aproach
Dim lRow As Long: lRow = shData.Cells(1, 1).End(xlDown).Row
Dim lCol As Long: lCol = shData.Cells(1, shData.Columns.Count).End(xlToLeft).Column
'Declare some further variables to help
Dim R As Long, X As Long
Dim sumFormula As String
'Declare and set your array to hold your data - much faster to iterate through the array than spreadsheet itself
Dim tblData(): tblData = shData.Range(shData.Cells(1, 1), shData.Cells(lRow, lCol))
For R = LBound(tblData) + 1 To UBound(tblData) 'Iterate through your data
For X = LBound(tblData) + 1 To UBound(tblData) 'Iterate through the same data again
If tblData(R, 4) = tblData(X, 4) And X > R Then 'Check for match with the next client found (assuming clients are unique)
'Set your formula to a variable, helps with debugging
sumFormula = "=SUM(R[-" & X - R & "]C[-2]+R[-" & X - R & "]C[-1])"
'Assign the formula to the respective cell _
If the spreadsheet is massive, you might need to add some optimisation _
(ie: assign everything to an array first, then dump into the spreadsheet)
shData.Cells(X, 7).FormulaR1C1 = sumFormula
End If
Next X
Next R
End Sub
Note: It won't add anything to the first few lines or new clients, as there is nothing to match against previously, but i expect that should work the same with any formula too.
I'm building a project management spreadsheet where multiple teams are going to have a copy. I want to create a simple address book. I have the names of the teams in a table and using VBA, I create the Master Table.
In the range B4:D5 there is a simple table with three column names:
Name
Telephone
Email
I have named this table (in Name Manager) as ContactTeam1
I want to copy and paste this exact 3x2 table to be below each corresponding team such as the image Here and change each Named Table as ContactTeam2, ContactTeam3 and so on.
The reason I want to use VBA is because, we have many different projects, so I want to automate the process as much as I can, for future projects as well.
I will fill in the tables with all the necessary information (Names,Phones,Emails) - by hand. The reason I want to use tables is that it has the benefit to auto-expand to include any new lines below the last.
As a bonus functionality, when somebody clicks the cell on top that contains the name of the Team. (Team Blue, Team Red etc.) all the emails of the corresponding range will be copied to clipboard, to be used in an email client. (This can be done easier with tables - one more reason I want to use them).
I hope this helps
Sub Bouton()
Dim cell As Range
Dim rng As Range
Dim cnt As Integer
Dim RangeName As String
Dim CellAdd1, CellAdd2 As String
For cnt = 2 To ActiveSheet.Range("NumberTimes")
Set rng = Range("ContactTeam" & (cnt - 1))
RangeName = "ContactTeam" & cnt
CellAdd1 = Cells(rng.Row, rng.Column + 3).Address
CellAdd2 = Cells(rng.Row + 1, rng.Column + 5).Address
'+ 1 in the row so the named range goes from B4 to D5
Set cell = ActiveSheet.Range(CellAdd1, CellAdd2)
ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=cell
Range("ContactTeam1").Copy Range("ContactTeam" & cnt)
Next cnt
End Sub
I'm not the best in VBA, but what this does is that it creates a new range each 3 cells and names it from ContactTeam2 to whatever your limit is. I created a named range called NumberTimes. Basically, you tell it how many new ranges you want to be created.
easiest of all, i guess we can use dictionary here. would be faster but here he what i tested/tried , EXACTLY on your data and works.
Sub d()
Sheet1.Select
Range("b3").Select
Do
Range("b3:d4").Name = "mainteam"
ActiveCell.Offset(0, 3).Select
Range("mainteam").Copy ActiveCell
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Name = "team" & i
i = i + 1
Loop While i <> 5
End Sub