Help with coding (Macro)

[Mikroicy]

I am a bit new to coding and I would require some help with creating a macro in excel. What I need it to do is to copy a range of cells (multiple columns) depending on the value in a cell above each column and paste them in Word table. In attachment is the excel table I am refering to. In excel, I made an equation that when you increase the number of test and reference the following change is made: (1) Test --> (2) Test 1 and Test 2 --> (3) Test 1 Test 2 and Test 3 and the same goes for the reference. So the higher the number of Test and Reference, the more columns I need to copy paste into Word document (so only the columns that have Test, Test 1,... Reference, Reference 1,... should be copied into Word; excluding the ones that have empty cells above the column in table). That is the first part (first Word document filled).

the second part is: I need to create a few more Word documents. This time I need to copy individual coulms from excel to Word document (same excel file, just a new macro). I would like to copy the column with the value Test into a Word document then if Test 1 also exists create a second document and paste the column that has Test 1 in cell above into Word and so on until max Test 4 (and the same for reference). In case I had 4 coulms with Test (Test 1, Test 2, Test 3 and Test 4) in Excel, I would create 4 Word documents with 4 different Tables (using 1 Word template document).

If anyone likes a challenge, you can give it a go. Would help me ease my job a bit :)

16555

[Mikroicy]

For the first part, my code is as written below. I have connected multiple cells to 1 Word document. I just need to add/improve it so it can do as mentioned above.


Sub Shippingrecord()
Dim wdApp As Object
Dim strTMP1 As String
Dim strTMP2 As String
Dim strTMP3 As String
Dim strTMP4 As String
Dim strTMP5 As String
Dim strTMP6 As String
Dim strTMP7 As String
Dim Fname As String
Dim Auto As String
Dim Full As String
strTMP1 = Range("Osnove!B12")
strTMP2 = Range("Osnove!B13")
strTMP3 = Range("Osnove!B4")
strTMP4 = Range("Osnove!C4")
strTMP5 = Range("Mape!B88")
strTMP6 = Range("Mape!A88")
Fname = Sheets("Mape").Range("C12").Text
Auto = "\Shipping record"
Full = Fname & Auto & ".docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
With wdApp
.Visible = True
.Documents.Open "document location" 'adapt
.ActiveDocument.Bookmarks("Koda").Range = strTMP1
.ActiveDocument.Bookmarks("CRO").Range = strTMP2
.ActiveDocument.Bookmarks("Sender").Range = strTMP3
.ActiveDocument.Bookmarks("Mail").Range = strTMP4
.ActiveDocument.Bookmarks("Naslov").Range = strTMP5
.ActiveDocument.Bookmarks("Kontakt").Range = strTMP6
If Not Dir(Full) = "" Then 'filename exists
Do
i = i + 1
Full = Fname & Auto & i & ".docx"
Loop Until Dir(Full) = "" ' loop till filename not found
End If
.ActiveDocument.SaveAs Filename:=Full
wdApp.Activate
'.ActiveDocument.Close
End With
Set wdApp = Nothing
End Sub

[Mikroicy]

Solved it by myself. Tnx anyways. the second part was a bit trickier but solved it by creating multiple macros and then one macro that chooses the right one based on the value of one cell.

first part:


Sub Shippingrecord()
Dim wdApp As Object
Dim strTMP1 As String
Dim strTMP2 As String
Dim strTMP3 As String
Dim strTMP4 As String
Dim strTMP5 As String
Dim strTMP6 As String
Dim strTMP7 As String
Dim Fname As String
Dim Auto As String
Dim Full As String
Dim WdRange As Word.Range
Dim number As String

strTMP1 = Range("Osnove!B12")
strTMP2 = Range("Osnove!B13")
strTMP3 = Range("Osnove!B4")
strTMP4 = Range("Osnove!C4")
strTMP5 = Range("Mape!B88")
strTMP6 = Range("Mape!A88")
Fname = Sheets("Mape").Range("C12").Text
Auto = "\Shipping record"
Full = Fname & Auto & ".docx"
number = Sheets("Zdravila").Range("E4")

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")

If number = 1 Then Sheets("Zdravila").Range("table01").Copy
If number = 2 Then Sheets("Zdravila").Range("table012").Copy
If number = 3 Then Sheets("Zdravila").Range("table0123").Copy
If number = 4 Then Sheets("Zdravila").Range("table01234").Copy
If number = 5 Then Sheets("Zdravila").Range("table012345").Copy
If number = 6 Then Sheets("Zdravila").Range("table0123456").Copy

On Error GoTo 0
With wdApp
.Visible = True
.Documents.Open "document location" 'adapt
.ActiveDocument.Bookmarks("Koda").Range = strTMP1
.ActiveDocument.Bookmarks("CRO").Range = strTMP2
.ActiveDocument.Bookmarks("Sender").Range = strTMP3
.ActiveDocument.Bookmarks("Mail").Range = strTMP4
.ActiveDocument.Bookmarks("Naslov").Range = strTMP5
.ActiveDocument.Bookmarks("Kontakt").Range = strTMP6

Set WdRange = .ActiveDocument.Bookmarks("tabela").Range
On Error Resume Next
If number > 0 Then WdRange.Tables(1).Delete
If number > 0 Then WdRange.Paste

.ActiveDocument.Tables(1).AutoFitBehavior (wdAutoFitWindow)

If Not Dir(Full) = "" Then 'filename exists
Do
i = i + 1
Full = Fname & Auto & i & ".docx"
Loop Until Dir(Full) = "" ' loop till filename not found
End If
.ActiveDocument.SaveAs Filename:=Full
wdApp.Application.Activate
'.ActiveDocument.Close

End With
Set wdApp = Nothing
Set WdRange = Nothing
Application.CutCopyMode = False

End Sub