Copy Data and save in new book: Macro Modification Help

[jeetusaini85]

Dear All,

Request your help in VBA.

I have a code (Really good code, thanks to Mr. Vog) in which we can split the data using column values into new and same sheet also. I want to modify this accordingly to my need but i am new in VBA so can't modify this. i want 2 changes in this macro:

1. I want to set a value (Like:"Resolved"," In Process" ) in the macro to extract the data related to the value only. Means, when i run this macro it will extract the data only for "Resolved" status. I have to create two macros for each defined status.

2. After splitting, it will ask me to save the new workbook location.

3. Save it.

The codes i m having are :

First code to make directories:

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
 
'   Root folder = Desktop
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the dialog
    x = SHBrowseForFolder(bInfo)
    
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

for extract the data :

Sub Lapta()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xls"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub

 

[jeetusaini85]

Can anyone help me on this please?

 

[jeetusaini85]

Can anyone help me on this please?

 

[jeetusaini85]

Bump

 

[pawanhsharma]

Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '32-bit API declarations Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _ As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return bInfo.ulFlags = &H1 ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function Sub SplitDataSeperateSheet() Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String Dim sh As Worksheet, Master As String, Folder As String, Fname As String On Error Resume Next Set r = Application.InputBox("Click in the column to extract by", Type:=8) On Error GoTo 0 If r Is Nothing Then Exit Sub iCol = r.Column t = Now Application.ScreenUpdating = False With ActiveSheet Master = .Name lastrow = .Cells(Rows.Count, "A").End(xlUp).Row LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom iStart = 2 For i = 2 To lastrow If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then iEnd = i Sheets.Add after:=Sheets(Sheets.Count) Set ws = ActiveSheet On Error Resume Next ws.Name = .Cells(iStart, iCol).Value On Error GoTo 0 'ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A1") iStart = iEnd + 1 End If Next i End With Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then Folder = "Select the folder to save the workbooks" 'Folder = GetDirectory(Folder) If Folder = "" Then Exit Sub Prefix = InputBox("Enter a prefix (or leave blank)") Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name <> Master Then sh.Copy Fname = Folder & "\" & Prefix & sh.Name & ".xls" If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _ Title:=Fname & " exists - select file to save as") 'ActiveWorkbook.SaveAs FileName:=Fname ActiveWorkbook.Close End If Next sh Application.ScreenUpdating = True End If End Sub