मुझे अपने एक्सेल प्रोग्राम में समस्या हो रही है। मैं दूसरी शीट पर नाम और टेलीफोन नंबर चिपकाना चाहता हूं, लेकिन नामों को यादृच्छिक रूप से क्रमबद्ध किया जाना चाहिए और फोन नंबर समान होना चाहिए। उदाहरण के लिए पहली शीट में मेरे पास कलिन कलिनोव +22222222 और मार्टिन मार्टिनोव +99119911 हैं और दूसरी शीट पर कॉपी पेस्ट कार्रवाई के बाद उन्हें मार्टिन मार्टिनोव +99119911 और कलिन कलिनोव +22222222 जैसा होना चाहिए।

Sub GenerateNames()
Dim ssheet1 As Worksheet
Dim rnsheet As Worksheet
Set ssheet1 = ThisWorkbook.Sheets("Sheet1")
Set rnsheet = ThisWorkbook.Sheets("RandomNames")

ssheet1.Range("A3:A70").Copy rnsheet.Range("A3:A70")
ssheet1.Range("B3:B70").Copy rnsheet.Range("B3:B70")
End Sub  
0
Kalin Stoev 16 मई 2018, 09:57

2 जवाब

सबसे बढ़िया उत्तर

कुछ इस तरह जोड़ें, और इसे या तो स्रोत पत्रक पर या लक्ष्य पत्रक पर लागू करें:

Range("C3").Formula = "=RAND()"
Range("C3").AutoFill Destination:=Range("C3:C70")

Range("A:C").Sort key1:=Range("C3"), order1:=xlAscending, Header:=xlYes

यह यादृच्छिक मानों का एक स्तंभ बनाता है, जिसका उपयोग छँटाई के लिए किया जाता है। आप इसे बाद में हटाना चाह सकते हैं।

0
Sam 16 मई 2018, 10:31
Sub randomName()
Dim ws As String, ws2 As String, rg As Range, rg2 As Range
Dim DataRange As Variant, i As Integer
Dim n As Integer, tmp As String
Dim nData As Integer
      '== set by user
            nData = 70        '== data size
            ws = "sheet1":                ws2 = "RandomNames"     '== sheets name
            Set rg = Sheets(ws).Cells(3, 1):            Set rg2 = Sheets(ws2).Cells(3, 1)       '=range with start row
      '== Run
            rg2.Resize(nData, 2).Value = rg.Resize(nData, 2).Value
            DataRange = rg.Resize(nData).Value
            For i = 1 To UBound(DataRange)
                  n = CLng(Rnd(i) * Second(Now) * 100) Mod UBound(DataRange) + 1
                  If i <> n Then tmp = DataRange(n, 1):          DataRange(n, 1) = DataRange(i, 1):         DataRange(i, 1) = tmp
            Next i
            rg2.Resize(nData) = DataRange:            Set rg = Nothing:            Set rg2 = Nothing
End Sub
0
fatique 16 मई 2018, 11:00