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.
Related
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!
I trying to get this forecast by date into a PivotTable so I can drill down the info for a CSV import. The pivot wizard recognises my data all wrong.
How can I get SKU codes as ROWS, all the dates dynamic to additions as COLUMNS and the forecast values as VALUES?
Excel Data
Failure
I want the Pivot to mirror what I have, so I can drill the data down to the format
SKU, Date, Qty
SKU, Date, Qty
SKU, Date, Qty
SKU, Date, Qty
If there is an alternative but easier route that would be great.
I think the problem you got is how you are storing your original data. Right now you are doing something like this:
And to make the Pivot Table work properly, you need tabular design like this:
Notice that same SKU code can appear more than once, but at different dates (row 12 and 19, row 13 and 20, and so on).
With this tabular design, then you can do a Pivot Table like you want:
So you need to transpose the data. I've used some formulas that may help you out a little bit. If you got a lot of data,then I strongly suggest you to use them and then paste values, or the file will be heavily overcharged, slow and so on. This is a way to do it.
First, count how many SKU codes you got (in my image, there are just 7)
Second, count how many dates you got (in my image, there are just 2)
Below original data, copy the complete group of SKU codes (7) as many times as dates (twice in my case) in the same column.
In next column (DATE field), you can use this formula: =INDEX($B$1:$C$1;1;COUNTIFS($A$12:A12;A12))
In next column (VALUE field) you can use: =INDEX($B$2:$C$8;MATCH(A12;$A$2:$A$8;0);MATCH(B12;$B$1:$C$1;0))
Just drag down and you should get a new range with data transposed properly. And that new range is a perfect source for a Pivot Table and do what you want. Paste values!
If you add new extra rows to this new range, you can just change the source of your Pivot Table, and then that new data will be instantly added to your Pivot Table with the design you want.
After checking everything is right, delete old data, of course!
I've uploaded a sample to my Gdrive in case it may help for you. https://drive.google.com/open?id=1ElEPkk5V3QkME7yLPQuGnU7-wd6fQEd_
Hope you can adapt this to your needs.
Thanks for taking the time to assist me, I managed to find a solution that I thought I'd share. This doesn't go down the PivotTable route but instead gives me the final result that I needed.
Sub NormaliseTable()
Application.Calculation = xlManual
' start with the cursor in the table
Dim rTab As Range, C As Range, rNext As Range
Set rTab = ActiveCell.CurrentRegion
If rTab.Rows.Count = 1 Or rTab.Columns.Count = 1 Then
MsgBox "Not a well-formed table!"
Exit Sub
End If
Workbooks.Add ' the sheet for the results
Set rNext = Range("A1")
For Each C In rTab.Offset(2, 1).Resize(rTab.Rows.Count - 1, _
rTab.Columns.Count - 1).Cells
If Not (IsEmpty(C.Value) Or C.Value = "0") Then
rNext.Value = rTab.Cells(C.Row - rTab.Row + 1, 1)
rNext.Offset(0, 1).Value = rTab.Cells(1, C.Column - rTab.Column + 1)
rNext.Offset(0, 2).Value = C.Value
Set rNext = rNext.Offset(1, 0)
End If
Next
ChDir "\\Client\T$"
ActiveWorkbook.SaveAs Filename:="\\Client\T$\M3-FC-IMPORT.csv", FileFormat _
:=xlCSV, CreateBackup:=False
ActiveWorkbook.Save
ActiveWindow.Close
Application.Calculation = xlAutomatic
End Sub
Without the Application Calculation going to manual it would take hours, so I turn it off and on with the macro and its almost instantaneous!
Thanks
Sam
This code is used to add new rows in three fields to an existing Excel template file. The current worksheet is used to create a three column collection, that is then compared to the same list of dogs registration numbers in the template. (Dog's registration numbers are unique to only one dog, no matter what breed.) Duplicates are removed from the collection and the remaining collection is then added to the end of the existing name list in the template (although I can't figure out how to add multiple dogs in one pass but I did successfully work around that).
The major problem I'm having is what appears to be a random inconsistency in getting the data correctly into the template. The spreadsheet columns are Registration Number, Dog Registered Name and Dog Call Name. Since the current workbook is created from the template, there should be no formatting differences to contend with.
The code never returns an error message of any sort. I've tried some Debug.Print routines that show that the data from the lists do not get written correctly into the collection. I have no idea why most of them occur but did figure out that if the Registered Name and Call Name fields are identical, the collection sees that as only one data point, not two. There is only one dog in the database with that quirk, but it would be helpful if I could figure out a fix for that.
During testing, I've had the code execute successfully four or five times then put garbage into the template - by garbage I mean it would put data in the wrong fields, enter only the registration number into all three template fields, stuff like that. To maintain consistency of testing I would use the same data each time, just to be clear.
(This code is for only one breed. I have 22 breeds in the spreadsheet. I tried to write a loop but the collection kept recognizing only the first breed. I'm not looking for an answer to that at the moment but am including it in case there's something in this code that was causing that problem as well.)
I've tried the Msgbox that shows what the data being collected looks like. It looks like the problem is occurring during the building of the collection but why it works sometimes and not others is baffling me.
I tried adding Stops after each section of the code to see if that helped. I can't say it did.
I did a ton of research on the net prior to even starting this but most of the help seemed to be finding items that matched then doing something, usually in the same workbook or worksheet. So I could be missing some snippet of code that will cure the problem.
I used Debug. Print to try and figure out what is corrupting the data but was unable to fully figure out a cause. I did have a few cases where one of the For..Each statements got hung up because the list.remove If statement wasn't executing any result when it should have been.
One might ask why I simply don't copy the entire Dog By BREED sheet from the current workbook to the template and save myself some hassle. There is a lot of other programming in this spreadsheet that uses the data on the sheet. My experience with cut and paste in Excel where formulas are concerned is all negative. I don't want to have five (non-consecutive) years of work blown up.
The instructions for showing the code say to use as little as possible so I've included only what I think is pertinent. If you need to see more just ask but I think this will work.
'=======================================================================
'Function is to add new items to the template from the current workbook.
'===========================================================================
' Create collection from current workbook. The collection has three fields.
'===========================================================================
Set list = CreateObject("System.Collections.ArrayList")
With wb1.Worksheets("Dogs by BREED")
For Each cell In .Range("H9", .Range("J" & .Rows.Count).End(xlUp))
If cell.Value <> "" Then
If Not list.Contains(cell.Value) Then list.Add cell.Value
End If
Next
End With
'============================================================
'Remove matches from collection that are already in template.
'============================================================
With wb.Worksheets("Dogs by BREED")
For Each cell In .Range("H9", .Range("J" & .Rows.Count).End(xlUp))
If list.Contains(cell.Value) Then list.Remove cell.Value
Next
End With
'=================================
'Update template with new records.
'=================================
With wb.Worksheets("Dogs by BREED")
If list.Count = 0 Then
Debug.Print "List Count is: " & list.Count, "Lastrow is: " & lastrow
Else
Do Until list.Count = 0
'MsgBox Join(list.ToArray, ", "), vbInformation, "New Data"
lastrow = .Range("H" & .Rows.Count).End(xlUp).Row + 1
'Debug.Print "List Count is: " & list.Count, "Lastrow is: " & lastrow
wb.Worksheets("Dogs by BREED").Range("H" & lastrow, "J" & lastrow).Value = list.ToArray
For Each cell In .Range("H9", .Range("J" & .Rows.Count).End(xlUp))
If list.Contains(cell.Value) Then list.Remove cell.Value
Next
Loop
End If
End With
list.Clear
Set list = Nothing
Data from the current workbook.
Reg Number Registered Name Call Name
HM55217902 DC Apu Must be the Money Trill
HM79741005 FC Thor's East Of Midnight MC LCX4 Midnight
HM85885107 FC Thor's Painter Passing Thru MC Girlfriend
HM92957602 FC Apu Occhi Belli Occhi
HP03103402 CH Kisa N' Akuba's Muddy Sneakers Rhubarb
HP08021401 DC Ahmahr Nahr's El Cerro Ranger JC Jake
HP11484805 Whimsical Mystical Nickel Nickel
Data from the template.
Reg Number Registered Name Call Name
HM55217902 DC Apu Must be the Money Trill
HM79741005 FC Thor's East Of Midnight MC LCX4 Midnight
HM85885107 FC Thor's Painter Passing Thru MC Girlfriend
HM92957602 FC Apu Occhi Belli Occhi
Expected result is that the last three rows of data are copied to the template.
Some actual results are:
The Reg Number was copied into all three fields in the template.
The Reg Number was omitted and the Registered Name was copied into the Reg Number field, and the Call Name into the Registered Name field. Any time a field was missing in the collection it becomes an issue that is not error trapped.
A simpler approach would do the job:
Dim cell As Range, v, rngTarget As Worksheet
With wb.Worksheets("Dogs by BREED")
Set rngTarget = .Range(.Range("H9"), .Cells(.Rows.Count, "H").End(xlUp))
End With
With wb1.Worksheets("Dogs by BREED")
For Each cell In .Range(.Range("H9"), _
.Cells(.Rows.Count, "H").End(xlUp)).Cells
v = cell.Value
If Len(v) > 0 Then
'is there a match in the target sheet?
If IsError(Application.Match(v, rngTarget, 0)) Then
'no match, so copy over
cell.Resize(1, 3).Copy _
rngTarget.Cells(rngTarget.Cells.Count).Offset(1, 0)
'add a row to the target range
Set rngTarget = rngTarget.Resize(rngTarget.Cells.Count + 1)
End If
End If
Next
End With
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
I have a downloaded bank statement on SHEET1 (ALL).
I have several widgets running along the side one of which
=SUMIF(C:C,H3,D:D)
Searches the Descriptions for the value in H3 (EG: * WAGES *) and totals up the corresponding value in D.
I now need to expand that so that it copies the entire ROW onto a new Spreadsheet.
I'd also like, if possible, to start with an input box so I can search for multiple things at once.
Various code that I have seen / tried will only work for exact values in Row C. But with the bank statement its never the same twice and I'd like it to wildcard the search if possible.
Thanks for your time.
Kind Regards
Alex Nicol
I have recently written VBA code just like this. Where I use the word payments, you can use the word Wages and include your wildcards like so:
a.Cells(b.Row, 16).Value LIKE "*Wages*"
Sub ShortTerm()
Dim a As Range, b As Range
Dim i As Long
Dim j As Long
Dim p As Long
Dim value1 As Variant
i = 4 'the start row for pasting
Set a = ThisWorkbook.Sheets("Payments").UsedRange
For Each b In a.Rows
'in the next line change 16 to reflect the column where WAGES is found
If a.Cells(b.Row, 16).Value = "Short Term" Then
For j = 1 to 16
value1 = a.Cells(b.Row, j).Value
ThisWorkbook.Sheets("DestinationSheet").Cells(i, j).Value = value1
Next
i = i + 1
End If
Next
End Sub
Obviously I am only copying 16 columns and so if that is all you want, this should work. If you need more, make that loop larger. There is probably a way to copy the whole row, but I had originally only wanted specific cells and I had wanted them reorganized which is why I did it the way I did.
See the post on my blog here:
http://automatic-office.com/?p=355