VBA: Move data into different worksheets based on column B and only unique values based on column P

ShadowLady17

New Member
Joined
May 19, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi, I'm completely new to VBA and am really struggling with this so if you have any advice please use simple language because I'm way out of my depth here.

So ideally, I'm looking to create a macro where I press a button and all the lines in the data tab will be sorted into different workbooks based on the account (column B) but only if the concatenate for that line is unique (column P). So, if the worksheet already has that line in there (50043032.07apple4141) then it won't be moved over.


Company CodeAccountDocument typeAssignmentAmount in local currencyTextPurchasing DocumentDocument DateProfit CenterFiscal YearPosting periodUser NameDocument NumberPosting DateReferenceConcatenate
1210500430SAADJNIGJ32.07apple14/09/2022414120236GRIFFITF50043032.07apple4141
1210500430SAADJNIGJ2.90banana14/09/2022413220236GRIFFITF5004302.9banana4132
1210500430SAADJNIGJ2.46carrot14/09/2022414620236GRIFFITF5004302.46carrot4146
1210500430SAADJNIGJ32.07apple14/09/2022414120236GRIFFITF50043032.07apple4141
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Try This

Option Explicit

Sub ExportToWorkbooks()

Const aibPrompt As String = "Which column would you like to filter by?"
Const aibtitle As String = "Filter Column"
Const aibDefault As Long = 3

Dim dFileExtension As String: dFileExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim dFolderPath As String: dFolderPath = "C:\Test\" ' Path your folder

If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension

Application.ScreenUpdating = False

Dim sCol As Variant
sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1) 'Column P = 16
If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
If sCol = False Then Exit Sub ' canceled

Dim sws As Worksheet: Set sws = ActiveSheet
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 3 Then Exit Sub ' not enough rows
Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
Dim scrg As Range: Set scrg = srg.Columns(sCol)
Dim scData As Variant: scData = scrg.Value

' Write the unique values from the 1st column to a dictionary.

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case insensitive

Dim Key As Variant
Dim r As Long

For r = 2 To srCount
Key = scData(r, 1)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Sub ' only error values and blanks
Erase scData

Dim dwb As Workbook
Dim dws As Worksheet
Dim dfcell As Range
Dim dFilePath As String

For Each Key In dict.Keys
' Add a new (destination) workbook and reference the first cell.
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
Set dfcell = dws.Range("A1")
' Copy/Paste
srrg.Copy
dfcell.PasteSpecial xlPasteColumnWidths
srg.AutoFilter sCol, Key
srg.SpecialCells(xlCellTypeVisible).Copy dfcell
sws.ShowAllData
dfcell.Select
' Save/Close
dFilePath = dFolderPath & Key & dFileExtension ' build the file path
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next Key

sws.AutoFilterMode = False
Application.ScreenUpdating = True

MsgBox "Data exported.", vbInformation

End Sub
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top