Macro to update columns depending on row identifier

[Silver]

There are 2 sheets Main File and DBR Report.

Main File is where the data is pasted.Since data is generated for 2 clients (code is AA and US) it contains 2 buttons.

DBR Report contains Template into which data is pasted into specific columns from Main File.

What the Macro does is -

1)When AA button is clicked, data from Main File is pasted into specific columns in the Template and Column Q is updated with Code AA. Same activity is performed when US button is clicked only Column Q is updated with Code US.

2)Depending on the volume of data in the Main File the macro adds or deduct rows from the template format.

3)Duplicates data in Columns A and B one below the other

4)Creates individual workbook of DBR Report sheet and saves it as AA_REACC_Draft_20Apr

Note :
Data is pasted into the template from Column C to R - Row 4 onwards.

Below is the code


Option Explicit

Sub test(colQ As String)

'Clears Existing data in Template


Sheets("DBR Report").Rows("6:500").Delete
Sheets("DBR Report").Range("C4:R5").ClearContents


'Creates Correct number of rows in template


Dim r, Lastrow As Integer


Lastrow = Sheets("main file").Range("A" & Rows.Count).End(3).Row


r = 2
Do While r + 1 <= Lastrow
If Range("A" & r) <> "" Then
Sheets("DBR Report").Rows("4:5").Copy Sheets("DBR Report").Rows(Rows.Count).End(3)(2)
End If
r = r + 1
Loop


'Copies data into template


Dim a, i As Long, n As Long, temp, e
a = Sheets("main file").UsedRange.Value: n = 2
With Sheets("dbr report")
For i = 2 To UBound(a, 1)
If a(i, 1) <> "" Then
n = n + 2
.Cells(n, 3).Resize(, 7).Value = _
Array(Val(a(i, 4)), a(i, 6), a(i, 8), a(i, 10), a(i, 12), _
DateValue(Left$(a(i, 2), 4) & "/" & Mid$(a(i, 2), 5, 2) & "/" & Right$(a(i, 2), 2)), _
DateValue(Left$(a(i, 3), 4) & "/" & Mid$(a(i, 3), 5, 2) & "/" & Right$(a(i, 3), 2)))
.Cells(n, 18).Value = a(i, 1)
.Cells(n, 17).Value = colQ
For Each e In Split(StrConv(Replace(a(i, 14), " ", ""), 64), Chr(0))
If e <> "" Then .Cells(n, Val(e) + 9).Value = e
Next
End If
Next
End With


'Exports Template


Sheets("DBR Report").Copy
ActiveSheet.Name = "AA_REACC_Draft_" & Format(Now, "ddmmm")
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & colQ & "_REACC_Draft_" & Format(Now, "ddmmm") & ".xlsx"
End Sub


Rows in Column A are identified as (In the Template)

Row4 - FR:
Row5 - TO:
Row6 - FR:
Row7 - TO:

Basically macro copies data onto rows which reflect FR: and leaves rows reflecting TO: blanks
(Done from Column C to R)

Looking for below additions to the above code :

1)Above code pastes code AA or US to rows reflecting FR: only in Column Q. Want the code to paste AA or US to rows reflecting FR: and TO:

2)Column H and I (Template) is updated with Dates in rows reflecting FR: only. Want the macro to update 1st set of dates to rows reflecting FR: and TO: 2nd set of dates to the next row reflecting FR: and TO:

Ex :

Date in Main File (Column B and C)


20150828
20150831


20150328
20150330



Template


FR:
28-Aug-15
31-Aug-15


TO:
28-Aug-15
31-Aug-15


FR:
28-Mar-15
30-Mar-15


TO:
28-Mar-15
30-Mar-15



Attached sample sheet with explanation (DBR Report will give an idea what exactly I want)

[p45cal]

try making the highlighted changes:


If a(i, 1) <> "" Then
n = n + 2
.Cells(n, 3).Resize(, 7).Value = _
Array(Val(a(i, 4)), a(i, 6), a(i, 8), a(i, 10), a(i, 12), _
DateValue(Left$(a(i, 2), 4) & "/" & Mid$(a(i, 2), 5, 2) & "/" & Right$(a(i, 2), 2)), _
DateValue(Left$(a(i, 3), 4) & "/" & Mid$(a(i, 3), 5, 2) & "/" & Right$(a(i, 3), 2)))
.Cells(n, 8).Resize(, 2).Copy .Cells(n + 1, 8)
.Cells(n, 18).Value = a(i, 1)
.Cells(n, 17).Resize(2).Value = colQ
For Each e In Split(StrConv(Replace(a(i, 14), " ", ""), 64), Chr(0))
If e <> "" Then .Cells(n, Val(e) + 9).Value = e
Next
End if

now in code tags (I can't highlight within code tags):
If a(i, 1) <> "" Then
n = n + 2
.Cells(n, 3).Resize(, 7).Value = _
Array(Val(a(i, 4)), a(i, 6), a(i, 8), a(i, 10), a(i, 12), _
DateValue(Left$(a(i, 2), 4) & "/" & Mid$(a(i, 2), 5, 2) & "/" & Right$(a(i, 2), 2)), _
DateValue(Left$(a(i, 3), 4) & "/" & Mid$(a(i, 3), 5, 2) & "/" & Right$(a(i, 3), 2)))
.Cells(n, 8).Resize(, 2).Copy .Cells(n + 1, 8)
.Cells(n, 18).Value = a(i, 1)
.Cells(n, 17).Resize(2).Value = colQ
For Each e In Split(StrConv(Replace(a(i, 14), " ", ""), 64), Chr(0))
If e <> "" Then .Cells(n, Val(e) + 9).Value = e
Next
End if

[Silver]

Works Perfect... Just 1 more point I missed out

We started receiving this problem last week only.

Weeks are termed into numbers

Mon - 1
Tues - 2
Wed - 3
Thur - 4
Fri - 5
Sat - 6
Sun - 7

Columns in Template are termed into numbers

J - 1
K - 2
L - 3
M - 4
N - 5
O - 6
P - 7

So when the button is clicked the respective column is updated with respective numbers

We used to receive weeks in numbers as below

Column N in Main File


17


2345


12567



Now we are receiving it as below



1xxxxx7


x2345xx


12xx567



Macro should update the respective columns in Template with numbers only.
(No matter what characters are used macro should update numbers only)

[Silver]

Since Column N (Main File) contains numbers 1 to 7 only. Can a macro be created to remove any alphabets and special characters just keeping numbers 1 to 7

Ex :

1xxxxx7
x2345xx
12xx567

After the macro is run it should look like this
17
2345
12567

This will be a separate macro

p45cal your assistance will be much appreciated.

[p45cal]

change:
For Each e In Split(StrConv(Replace(a(i, 14), " ", ""), 64), Chr(0))
If e <> "" Then .Cells(n, Val(e) + 9).Value = e
Next
to:
For e = 1 To Len(a(i, 14))
myNum = Val(Mid(a(i, 14), e, 1))
If myNum > 0 And myNum < 8 Then .Cells(n, myNum + 9).Value = myNum
Next e
not forgetting elsewhere to Dim as follows:
e as Long, myNum as Long

[Silver]

Working Perfectly

p45cal U R GR8
THANKS A TONNE... Specially for your TIME and PATIENCE :clap: :super::clap: