atif3001 said:
faisal bahi ap ka bohat bohat shokria keh ap nay reply kia aur bohat mehnat ki.....
main nay ap kay thread dekha tu andaza hoa hai keh ap meri bat samaj gay han...keh main chahta hon keh sheet1 par jo mukhtalif parties ki Entry hoee han..wo khud ba khud apni apni sheet par post ho jay..hamay copy past na karni pray....ap nay hal btaya hai key Micro ko istamal kraon ???? mujay samaj nahin ayee keh sheet1 par Micro ko kis tran istaml krao..please h me...
Aik Hal to ap ko Faisal Sb n bataya ha.Aik aur hal ya ha . Give it a try follow the following procedure. Remember Ap k customer Column B m hain is ko dekh kar code banaya gaya ha.
1. Apni Worksheet open karian
2. Alt+F11 press Karain
3. Open Honi wali windows m Insert k menu m ja kar Module select Karain.
4. Aur ya code paste kar k window close kar dain,
Code:
Option Explicit
Sub FilterCustomer()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
'include bottom most header row
Const TopLeftCellOfDataBase As String = "A2"
'what column has your key values
Const KeyColumn As String = "B"
'where's your data
Set DataBaseWks = Worksheets("Sheet1")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
rsp = MsgBox("Include headings?", vbYesNo, "Headings")
Set TempWks = Worksheets.Add
With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With
'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True
'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With
With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With
'check for individual Customer worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If
If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If
'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)
'transfer data to individual Customer worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
MsgBox "Data has been sent"
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Sheet 1 m he rahte howe Alt+F8 Press karain aur Macro ko run karain. Aap ka tmama data apni apni sheets par copy ho gai ga. AUr agar kisi customer ki sheet na hoe tu woh bhee ban jae gi.
Regards,
Bookmarks