ऑटो एक एक्सेल दस्तावेज़ से वर्ड में तालिका बनाने

Question

मैं Excel में डेटा का एक सेट है, जो नीचे की तरह है (एस वी प्रारूप में)

heading1, heading2, heading3, index 
A , randomdata1, randomdata2, 1 
A , randomdata1, randomdata2, 2 
A , randomdata1, randomdata2, 3 
B , randomdata1, randomdata2, 4 
C , randomdata1, randomdata2, 5 

मैं एक शब्द दस्तावेज है कि प्रस्तुत निर्माण ऑटो के लिए सक्षम होना चाहते हैं यह डेटा, जो अलग-अलग तालिकाओं में शीर्षक 1 द्वारा समूहित जानकारी है। शब्द तो दस्तावेज़

तरह

Table A 
heading1, heading2, heading3, index 
A , randomdata1, randomdata2, 1 
A , randomdata1, randomdata2, 2 
A , randomdata1, randomdata2, 3 

Table B 
heading1, heading2, heading3, index 
B , randomdata1, randomdata2, 4 

Table C 
heading1, heading2, heading3, index 
C , randomdata1, randomdata2, 5 

कृपया कोई इस के साथ मेरी मदद कर सकता है के रूप में यह बहुत उबाऊ प्रतिलिपि & चिपकाने और स्वरूपण के बारे में 20 घंटे की बचत होगी होगा!

किसी भी मदद

Answer 1

डोरी के लिए धन्यवाद,

आशा इस समय मदद करने के लिए है।

इस काम के लिए आपको वर्ड का संदर्भ सेट करने की आवश्यकता है - वीबीए संपादक में टूल्स> संदर्भ चुनें और माइक्रोसॉफ्ट वर्ड ## पर स्क्रॉल करें, जहां एक्सेल '07 के लिए ## 12.0 है, एक्सेल '03 के लिए 11.0, इत्यादि। जब भी आप इसे चलाते हैं तो चादर को फ़िल्टर नहीं किया जाना चाहिए, और यद्यपि आपको 1 शीर्षक से सॉर्ट करने की आवश्यकता नहीं है, मुझे लगता है कि आपके पास है।

कोड मानता है कि आपकी सूची सेल ए 1 में शीर्षलेख के साथ शुरू होती है। अगर यह सच नहीं है तो आपको इसे बनाना चाहिए। यह भी मानता है कि डी में आपका अंतिम कॉलम आप उस पंक्ति में समायोजित कर सकते हैं जो "कॉपी" से शुरू होता है।

Sub CopyExcelDataToWord() 

Dim wsSource As Excel.Worksheet 
Dim cell As Excel.Range 
Dim collUniqueHeadings As Collection 
Dim lngLastRow As Long 
Dim i As Long 
Dim appWord As Word.Application 
Dim docWordTarget As Word.Document 

Set wsSource = ThisWorkbook.Worksheets(1) 
With wsSource 
    lngLastRow = .Range("A" & Rows.Count).End(xlUp).Row 
    Set collUniqueHeadings = New Collection 
    For Each cell In .Range("A2:A" & lngLastRow) 
     On Error Resume Next 
     collUniqueHeadings.Add Item:=cell.Value, Key:=cell.Value 
     On Error GoTo 0 
    Next cell 
End With 
Set appWord = CreateObject("Word.Application") 
With appWord 
    .Visible = True 
    Set docWordTarget = .Documents.Add 
    .ActiveDocument.Select 
End With 
For i = 1 To collUniqueHeadings.Count 
    With wsSource 
     .Range("A1").AutoFilter Field:=1, Criteria1:=collUniqueHeadings(i) 
     .Range("A1:D" & lngLastRow).Copy 
    End With 
    With appWord.Selection 
     .PasteExcelTable linkedtoexcel:=False, wordformatting:=True, RTF:=False 
     .TypeParagraph 
    End With 
Next i 

For i = 1 To collUniqueHeadings.Count 
    collUniqueHeadings.Remove 1 
Next i 
Set docWordTarget = Nothing 
Set appWord = Nothing 

End Sub