Dim sourcewb As Workbook
Dim targetWorkbook As Workbook
Dim filter As String
Dim filter2 As String
Dim rw As Long
Dim lookup As String
Dim X As Range
Dim y As Range
Dim a, b As Variant
Set sourcewb = ActiveWorkbook
Set X = sourcewb.Worksheets(1).Range("A:G")
Dim sourceSheet As Worksheet
Set sourceSheet = sourcewb.Worksheets(1)
MsgBox sourceSheet.Name
X.Select
MsgBox sourcewb.Name
filter = "(*.xls),*.xls"
Caption = "Please Select an input file "
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename(filter, , Caption)
Set targetWorkbook = Application.Workbooks.Open(Filename)
Set y = targetWorkbook.Worksheets(1).Range("A:G")
y.Select
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
MsgBox targetSheet.Name & " This is the country code sheet name "
Set targetWorkbook = ActiveWorkbook
MsgBox targetWorkbook.Name
y.Select
sourcewb.Activate
MsgBox ActiveWorkbook.Name & " IS the active workbook"
MsgBox sourcewb.Name
MsgBox sourcewb.Name & " This is the source workbook "
MsgBox targetWorkbook.Name & " This is the target workbook "
MsgBox "Trying to map from target to source "
With sourcewb.Worksheets(1)
For rw= 2 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(rw, 4) = Application.VLookup(Cells(rw, 1).Value, y, 4, False)
'MsgBox Cells(a, 4).Value2
Next rw
End With
MsgBox "All required columns from source mapped to target file "
Set sourcewb = ActiveWorkbook
MsgBox ActiveWorkbook.Name
Application.ScreenUpdating = False
I have a workbook sourcewb. I open another workbook targetworkbook from the sourceworkbook. My Columns in sourcewb are Sl No, Country code,country names
slno country code country name Region
1 AL Algeria
2 US USA
3 UK United Kingdom
My targetwb is
country code country name Region
AL Algeria EMEA
US USA Americas
UK United Kingdom Europe
I am trying to fetch Region column from country code in the sourcewb as there is no slno in the targetwb and the order of country codes are not the same as sourcewb.
I get an error 2042. I have tried storing the target value with string, int, long, variant, nothing has worked till now.
Any suggestions or help would be really helpful.
With some "clean-up" and organization to your original code, try the code below.
3 comments:
When you are using a With statement, don't forget to nest all objects inside with a ..
Stay away from using Select and Activate, not only it's not necessary, it also slows down your code's run-time.
You need to trap the scenario that Application.VLookup will not find a value, and then you will get a run-time error.
Explanations inside the code as comments.
Code
Option Explicit
Sub AutoVLookup()
Dim sourcewb As Workbook
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim X As Range
Dim y As Range
Dim filter As String
Dim filter2 As String
Dim rw As Long
Dim lookup As String
Dim a, b As Variant
Set sourcewb = ActiveWorkbook ' set Activeworkbook object
Set sourceSheet = sourcewb.Worksheets(1) ' set source sheet
Set X = sourceSheet.Range("A:G") ' set source range
filter = "(*.xls),*.xls"
Caption = "Please Select an input file "
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename(filter, , Caption)
Set targetWorkbook = Workbooks.Open(Filename) ' set target workbook object
Set targetSheet = targetWorkbook.Worksheets(1) ' set target sheet
Set y = targetSheet.Range("A:G") ' set target range
With sourceSheet
For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row ' get last row in column A
' make sure VLoookup found a match, otherwise you will get a run-time error
If Not IsError(Application.VLookup(.Cells(rw, 1).Value, y, 4, False)) Then
.Cells(rw, 4) = Application.VLookup(.Cells(rw, 1).Value, y, 4, False) ' this will fetch column "E" values
'MsgBox Cells(a, 4).Value2
End If
Next rw
End With
MsgBox "All required columns from source mapped to target file "
Application.ScreenUpdating = True
End Sub
Related
I have the situation presented below in the image (Workbook 1):
and below (Workbook 2)
I want to copy my record from workbook 1 to workbook 2 if
in the Workbook 1 column A the string "surveyor" appears
the value from column B, which is exactly in the same row, where the string "suveyor" was found.
Then I would like to copy this value to my workbook 2.
I have prepared the code like this:
Sub FrontsheetAdd3()
Dim x As Worksheet, y As Worksheet, sPath As String
Dim i As Long
sPath = ThisWorkbook.Path & "\Survey_form.csv"
Set x = Workbooks.Open(sPath)
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
'Name of the sheet is the same as Name of the workbook 1
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor" Then
x.Sheets("Survey_form").Rage("B" & i).Value = ("A" & i)
y.Sheets("Frontsheet").Range("D34").PasteSpecial
End If
Next i
End Sub
I have an error:
Method or data member not found
at the line
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor" Then
UPDATE:
After changing my code, which now looks like this:
Sub FrontsheetAdd3()
Dim x As Workbook, y As Workbook, sPath As String
Dim i As Long
sPath = ThisWorkbook.Path & "\Survey_form.csv"
Set x = Workbooks.Open(sPath)
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
'Name of the sheet is the same as Name of the workbook 1
For i = 1 To 40
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor"
Then
x.Sheets("Survey_form").Rage("B" & i).Value = ("A" & i)
y.Sheets("Frontsheet").Range("D34").PasteSpecial
End If
Next i
End Sub
At the line:
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
my active workbook (Workbook2), where the macro is meant to be is closing down and error Subscript out of range emerges.
What is missig then?
Please, try the next adapted code. It will copy from the csv file in the active one and exit loop:
Sub FrontsheetAdd3()
Dim x As Workbook, y As Worksheet, ws As Worksheet, sPath As String, i As Long
sPath = ThisWorkbook.path & "\Survey_form.csv"
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
Set x = Workbooks.Open(sPath): Set ws = x.Sheets(1)
For i = 1 To 40
If ws.Range("A" & i).value = "surveyor" Then
y.Range("D34").value = ws.Rage("B" & i).value: Exit For
End If
Next i
End Sub
A VBA Lookup
Use Option Explicit which forces you to declare all variables.
Use variables (more of them) to make the code more readable.
Use meaningful variable names: sPath is a great name while x and y used for workbooks are terrible.
Instead of the loop, use Application.Match.
You can basically copy in three ways: Copy, Copy with PasteSpecial or Copy by Assignment (dCell.Value = sCell.Value) the latter being the most efficient when copying only values.
Option Explicit
Sub FrontsheetAdd3()
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets("Frontsheet")
Dim dCell As Range: Set dCell = dws.Range("D34")
Dim sPath As String: sPath = dwb.Path & "\Survey_form.csv"
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = wb.Worksheets("Survey_form")
' Determine the position of the first occurence of "surveyor" in column 'A'.
Dim sIndex As Variant
sIndex = Application.Match("surveyor", sws.Columns("A"), 0)
If IsNumeric(sIndex) Then ' "suveyor" was found
Dim sCell As Range: Set sCell = sws.Rows(sIndex).Columns("B")
dCell.Value = sCell.Value
Else ' "surveyor" was not found
dCell.Value = ""
End If
swb.Close SaveChanges:=False
'dwb.Save
End Sub
I am trying to compile data from one large workbook (that will be downloaded once a month) to one that is more concise. I will be pulling in new data every month. I will know the name of the source file and it's location.
Below is the code I am trying to run. It appears to run without errors (going thru all the FOR's and Do Until's) but is just not moving the data from the source file to the destination file. The variable information I am using is column O starting on line 14 of the destination WB. I am trying to sort thru column A of the source WB for some text and the variable from the destination WB. If I have a match I am trying to offset from the matching cell (down 3 rows and right 2 columns) and copy that information to an offset cell on the destination WB (left 4 columns on the same row). Also copying from down 10 rows and right 2 columns on the source to down row 1 and left 4 columns on the destination.
Sub Get_Scorecard()
Dim SourceFile As String
Dim DestFile As String
Dim SourceWB As Workbook
Dim SourceWS As Worksheet
Dim DestWB As Workbook
Dim DestWS As Worksheet
Dim path As String
Dim Msg As String
Dim SCount As Long
Dim sourcestart As Range
Dim TechName As String
'Set starting cell on Dest WS
Range("O14").Activate
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Set all the WB's and WS's
path = Application.ThisWorkbook.path & "\"
SourceFile = path & "March Test.xlsx"
DestFile = path & "JobSteps 2019 Test.xlsm"
Set SourceWB = Application.Workbooks.Open(SourceFile)
Set SourceWS = SourceWB.Sheets(1)
Set DestWB = Application.Workbooks.Open(DestFile)
Set DestWS = DestWB.Sheets(1)
'Start in O14 on the Dest WS and loop down till column O is empty
Do Until IsEmpty(ActiveCell.Value)
TechName = ActiveCell.Value
DestStart = ActiveCell.Address
'Start in Cell A2 on the soure WS and search for tech from Dest WS
For SCount = 2 To 700
If SourceWS.Range("A" & SCount).Text = "Provisioning*" & _
TechName & "*" Then
'copy info from 2 offset cells from SourceWS to 2 offset cells on DestWS
'I am offseting 4 columns to left on the DestWS just to see if they appear
DestWS.Range(DestStart).Offset(0, -4).Value = SourceWS.Range(SourceWS.Range _
("A" & SCount).Address).Offset(3, 2).Text
DestWS.Range(DestStart).Offset(-1, -4).Value = SourceWS.Range(SourceWS.Range _
("A" & SCount).Address).Offset(10, 2).Text
End If
Next SCount
'Offset active cell on DestWS by 4 rows
ActiveCell.Offset(4, 0).Activate
Loop
'Close SourceWB
SourceWB.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Range("A1").Activate
End Sub
I'm new to VBA and trying to put together a macro to copy in data from another workbook and then hyperlink values on an existing sheet to the sheets i've copied in based on a string value in a cell. For the most part the script works however i'm getting a type mismatch error. Hoping someone can help identify what i'm doing wrong.
Sub CopyTitleDetailData()
'Copy all sheets from Key New Release Detail sheet, overrides existing sheets, copys in new sheets
Dim wb As Workbook, ws As Worksheet, wbTarget As Workbook, wsTarget As Worksheet
Application.ScreenUpdating = False
Set wb = ActiveWorkbook 'Main workbook
Dim pth As String
pth = wb.Path
Dim titleDetailPth As String
titleDetailPth = Left(pth, InStrRev(pth, "\") - 1)
Dim filePthName As String
filePthName = titleDetailPth & "\Files for Pre-Order Report (Macro & Alteryx)\" & "Key New Release Accounts Details.xlsx"
Set wbTarget = Workbooks.Open(filePthName, UpdateLinks = False, ReadOnly = True)
For Each wsTarget In wbTarget.Worksheets 'A loop for each worksheet in the Key New Release Detail workbook
For Each ws In wb.Worksheets 'A loop for each worksheet in the Pre-Order (i.e. active workbook)
If wsTarget.Name = ws.Name Then 'If the sheet I am importing exists, it will be deleted
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
wsTarget.Copy After:=wb.Sheets(wb.Sheets.Count) 'Copies it into the last sheet
wb.Sheets(wsTarget.Name).Visible = 0 'Hides the copied sheets
Next wsTarget
wbTarget.Close SaveChanges:=False
Application.ScreenUpdating = True
'Loops through a specified column and when a specified value is found, puts a hyperlink in the cell below
Const cWsName As String = "Title Detail"
Const cSearch As String = "Title"
Const cRow1 As Integer = 1
Const cRow2 As Integer = 800
Const cCol As String = "D"
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCell1 As Range
Dim rCell2 As Range
Dim iR As Integer
Dim strText As String
Dim strAddr As String
Set oWb = ActiveWorkbook
Set oWs = oWb.Worksheets(cWsName)
For iR = cRow1 To cRow2
Set rCell1 = oWs.Range(cCol & iR)
Set rCell2 = oWs.Range(cCol & iR + 1)
strText = rCell2.Text 'What's written in the cell.
strAddr = rCell2.Address 'The address e.g. B1, B13 ...
If rCell1 = cSearch Then
If strText <> "" Then
'Anchor is the place where i'm placing the hyperlink.
'SubAddress is where the hyperlink will take you
rCell2.Hyperlinks.Add _
Anchor:=rCell2, _
Address:="", _
SubAddress:="'" & rCell2 & "'!" & "A1", _
TextToDisplay:=strText 'The same text that orginally lived in the cell
Else
'What im doing if the cell is empty (i.e. nothing)
End If
End If
Next
Dim beginRow As Long
Dim endRow As Long
Dim chkCol As Long
Dim rowCnt As Long
Dim rngResult As Range
beginRow = 1
endRow = 800
chkCol = 1
With oWs
.Cells.EntireRow.Hidden = False 'Unhides all rows, remove line if that's not desired
For rowCnt = beginRow To endRow
If .Cells(rowCnt, chkCol) = "X" Then
If rngResult Is Nothing Then
Set rngResult = .Cells(rowCnt, 1)
Else
Set rngResult = Union(rngResult, .Cells(rowCnt, 1))
End If
End If
Next rowCnt
End With
If Not rngResult Is Nothing Then rngResult.EntireRow.Hidden = True
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim oWs As Workbook
Dim targetString As String, targetSheet As Worksheet
Set oWs = ActiveWorkbook
targetString = Cells(Target.Range.Row, Target.Range.Column).Value
Set targetSheet = oWs.Sheets(targetString)
If targetSheet.Visible = False Then
targetSheet.Visible = True
End If
'End on Title Detail Sheet
targetSheet.Select
End Sub
Per this documentation, you have to provide an Address when adding a hyperlink. you seem to be setting Address = ""
https://learn.microsoft.com/en-us/office/vba/api/excel.hyperlinks.add
This code is for updating client information in my source document for a mail merge from a list that I can pull from my client server at any time.
I've hit a snag in this code near the end. The process it currently goes through is as follows:
user selects the merge document that needs to be updated
user selects the list with the updated addresses
code steps through the merge document, grabs the name of a company, then
searches through the second document for that company, copies the address information from the list, and
pastes it next to the company name in the merge document and
starts over with the next company name in the merge document
I'm currently stuck between steps four and five.'
here's a selection of the code I'm trying to adapt to search the source workbook, but I think this isn't going to work - I need to paste the found term into the macro workbook, and I have a gap in my knowledge of VBA here.
I can post my full code if necessary, but I didn't want to throw the whole thing in right away.
Thanks in advance!
Set sourcewkb = ActiveWorkbook
Dim rnnng As Range
Dim searchfor As String
Debug.Print celld
searchfor = celld
Set rnnng = Selection.Find(what:=searchfor)
If rnnng Is Nothing Then
Debug.Print "yes"
Else
Debug.Print "no"
End If
EDIT
I tried some of what was suggested in the comment, but I'm having an issue where the selection.find is finding the variable in question whether or not it's actually there. I think somehow it's searching in both workbooks?
Full code (some parts are marked out as notes for convenience during editing the code, they generally aren't the parts I'm concerned about):
UPDATED full code:
Sub addressfinder()
Dim rCell
Dim rRng As Range
Dim aftercomma As String
Dim celld As String
Dim s As String
Dim indexOfThey As Integer
Dim mrcell As Range
Dim alreadyfilled As Boolean
Dim nocompany As Boolean
Dim sourcewkb
Dim updaterwkb
Dim fd As FileDialog
Dim cellstocopy As Range
Dim cellstopaste As Range
Dim x As Byte
'select updater workbook
updaterwkb = "L:\Admin\Corporate Books\2015\letter macro\Annual Consent Letter Macro.xlsm"
'this is the finished updater workbook selecter.
' Set fd = Application.FileDialog(msoFileDialogFilePicker)
'
'
' Dim vrtselecteditem As Variant
' MsgBox "select the Annual Consent Letter Macro workbook"
'
' With fd
' If .Show = -1 Then
' For Each vrtselecteditem In .SelectedItems
'
'
' updaterwkb = vrtselecteditem
' Debug.Print updaterwkb
' Next vrtselecteditem
' Else
' End If
' End With
'select file of addresses
sourcewkb = "L:\Admin\Corporate Books\2015\letter macro\source workbook_sample.xlsx"
'this is the finished source select code
' Dim lngcount As Long
' If MsgBox("Have you gotten this year's updated contact list exported from Time Matters or Outlook?", vbYesNo, "confirm") = vbYes Then
' If MsgBox("Is the information in that excel workbook formatted per the instructions?", vbYesNo, "Confirm") = vbYes Then
' MsgBox "Good. Select that workbook now."
' Else
' MsgBox "Format the workbook before trying to update the update list"
' End If
' Else
' MsgBox "Have someone export you a client list with company name, client name, and client address"
'
' End If
'
'
' With Application.FileDialog(msoFileDialogOpen)
' .AllowMultiSelect = False
' .Show
' For lngcount = 1 To .SelectedItems.Count
' Debug.Print .SelectedItems(lngcount)
' sourcewkb = .SelectedItems(lngcount)
'
' Next lngcount
' End With
'
Workbooks.Open (sourcewkb)
'start the code
Set updaterwkb = ActiveWorkbook
Set rRng = Sheet1.Range("a2:A500")
For Each rCell In rRng.Cells
'boolean resets
alreadyfilled = False
nocompany = False
'setting up the step-through
s = rCell.Value
indexOfThey = InStr(1, s, ",")
aftercomma = Right(s, Len(s) - indexOfThey + 1)
celld = Left(s, Len(s) - Len(aftercomma))
Debug.Print rCell.Value, "celld", celld
Debug.Print "address", rCell.Address
'setting up already filled check
Set mrcell = rCell.Offset(rowoffset:=0, ColumnOffset:=6)
Debug.Print "mrcell", mrcell.Value
If Len(rCell.Formula) = 0 Then
Debug.Print "company cell sure looks empty"
nocompany = True
End If
If Len(mrcell.Formula) > 0 Then
Debug.Print "mrcell has content"
alreadyfilled = True
Else: Debug.Print "mrcell has no content"
End If
If alreadyfilled = False Then
If nocompany = False Then
'the code for copying stuff
'open source document
'search source document for contents of celld
'if contents of celld are found, copy everything to the right of the cell in which
'they were found and paste it horizontally starting at mrcell
'if not, messagebox "address for 'celld' not found
'Set sourcewkb = ActiveWorkbook
'
'Dim rnnng As Range
'Dim searchfor As String
'Debug.Print celld
'searchfor = celld
'
'Set rnnng = Selection.Find(what:=searchfor)
'If Not rnnng Is Nothing Then
' Debug.Print "yes"
' Else
' Debug.Print "no"
'
'End If
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("source workbook_sample.xlsx") 'change workbook name
Set ws1 = ThisWorkbook.Worksheets(1) 'change worksheet #
Set ws2 = wb2.Worksheets(1) 'change worksheet #
llc = ",LLC"
inc = ",INC."
'lastRow = ws1.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
'
Else
Debug.Print "skipped cuz there ain't no company"
End If
Else
Debug.Print "skipped cuz it's filled"
End If
''
'
Debug.Print "next"
Next rCell
End Sub
fixed code:
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:D100").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim company As String
Dim lastRow As Long
Dim rng As Variant
Dim llc As String
Dim inc As String
Dim searchfor As String
Set wb1 = ThisWorkbook 'Annual Consent Letter Macro
Set wb2 = Workbooks("source workbook_sample.xlsx")
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = wb2.Worksheets(1)
llc = ",LLC"
inc = ",INC."
With ws1
For i = 1 To 500
If Cells(i, 1).Value = searchfor Then
company = .Cells(i, 1)
With ws2
'change range as necessary
Set f = .Range("A1:A500").Find(company, LookIn:=xlValues)
If Not f Is Nothing Then
Debug.Print searcfor
fRow = f.Row
rng = .Range("B" & fRow & ":D" & fRow)
ws1.Range("B" & i & ":D" & i) = rng
End If
End With
End If
Next
End With
End Sub
I'm not experienced with VBA, but I think it's the only way for this to work.
I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.
I would like all the sheets to be filtered by sales team, and create a new workbook for each team.
I appreciate any help.
I got this solution.
Just send me an email if you need this solution.
At first I got this format:
I create the following macro code
Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook
Sub ExportWorksheet()
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkBook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
Application.DisplayAlerts = False
NewWorkBook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkBook
.SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours
End With
NewWorkBook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
Range("D5").Value = "Export Completed"
End Sub
Following is the output
I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.
enter Option Explicit
Dim personRows As Range 'Stores all of the rows found
'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False
' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.
For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column
If i = 0 Then ' We are starting, so generate new excel in memeory.
Workbooks.Add
Set wb = ActiveWorkbook
ThisWorkbook.Activate
End If
WritePersonToWorkbook wb, p.Value
i = i + 1 ' Increment the counter reach time
If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
counter2 = counter2 + 1
wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location.
wb.Close
Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL
i = 0
End If
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
ByVal Person As String)
Dim rw As Range
Dim firstRW As Range
For Each rw In UsedRange.Rows
If Not Not firstRW Is Nothing And Not IsNull(rw) Then
Set firstRW = rw ' WE want to add first row in each excel sheet.
End If
If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID"
If personRows Is Nothing Then
Set personRows = firstRW
Set personRows = Union(personRows, rw)
Else
Set personRows = Union(personRows, rw)
End If
End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub
please find below code
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim icol As Long
Dim l As Long
Dim headercol As Long
Dim stroutputfolder As String
stroutputfolder = "D:\Ba"
'dim str
icol = 1
headercol = 3
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = headercol + 1 To nLastRow
'Get the specific Column
'Here my instance is "B" column
'You can change it to your case
strColumnValue = objWorksheet.Cells(nRow, icol).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'MsgBox (varColumnValues(i))
If Dir(stroutputfolder, vbDirectory) = vbNullString Then MkDir stroutputfolder
If CStr(varColumnValue) <> "" Then
objWorksheet.UsedRange.Offset(headercol - 1, 0).AutoFilter Field:=icol, Criteria1:=CStr(varColumnValue)
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
'strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=stroutputfolder & "\" & CStr(varColumnValue) & ".xlsb", FileFormat:=50
ActiveWorkbook.Close savechanges:=False
l = l + 1
End If
Next
objWorksheet.ShowAllData
MsgBox (l & " files splitted")
End Sub