Need Help with VBA Code

Megha1484 · Feb 15, 2019

Hi,
I have been struggling with this VBA code for quite some time now and would appreciate any help with it. I have attached a sample spreadsheet I am working with. First sheet shows the raw data that comes from the SharePoint and second sheet shows the report I am trying to build form the raw data. Goal is to search for each question (starts at col C) and look for any “No – Correction Needed” and “No – Correction Not Needed” words and display the corresponding “ID”, “Name”, “Notes” associated with the question and “correction made”. I don’t want any “yes” or NA in the report only “Nos*”.
I have filled question “TND” as an example. So, when I run the code it should go through the entire col look for Nos and fill out rest of fields that comes from raw data. Here is the code I am trying to work with.
There are couple of issues with it. First, every time I will run the code it will start from scratch instead of picking up the row where it left off last. This could be an issue overtime when data starts building up.
Second, I am going to have to write the same code 32 times one for each question, which is OK as long as I can make this code work.
Third, I think its not recognizing the new report location where I am trying to build the report.

Sorry, I could not find a way to attach to Excel workbook so copied the sheets at the bottom of the email. First table is Rawdata and second table is Report. Thanks in advance!

Sub Report ()
'builds the report line by line based on iterative check of criteria

'clear old report data
Sheets ("Report").Select
Range("3:3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp

'set up for report build
Range("Report[Question ID]").Select

'iteratively search for selected criteria for Q1

Dim Q1Column As Range
Dim q1answer As Range
Dim q1current As Range

Set Q1Column = Sheets("Rawdata").Range("Table_Rawdata[Memo]")
For Each q1answer In Q1Column.Cells
If q1answer.Value Like "No*" Then
Set q1current = Range(Cells(ActiveCell))
Range("Report[@[Question ID]]").Select
Set ActiveCell.Value = "Q.1"
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = "TD"
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = "Deatiled Question Description"
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = "Memo"
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = Cells(q1current.Row, Range("Table_Rawdata[@[Name]]").Column)
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = q1answer.Value
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = Cells(q1current.Row, Range("Table_Rawdata[@[CorrectionsMade]]").Column)
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = Cells(q1current.Row, Range("Table_Rawdata[@[MemoNotes]]").Column)
ActiveCell.Offset(0, 1).Select
Set ActiveCell.Value = Cells(q1current.Row, Range("Table_Rawdata[@[ID]]").Column)

Else
End If
Next q1answer

'Next datum - copy code for the next question...
End Sub

RawData(Sheet1)

ID

Name

Memo

TND

STW

DecAcc

ConPro

CoD

BegDat

Duration

CP

Contribution

FIMF

MBP

Rpay

OffAcc

ReAcc

ReErr

Amt

ErrAmt

IC

Dmet

Status

ResAccute

Benaccu

PET

ComA

Au

Cplan

DMWU

SUIO

SalPre

Pdat

OUPY

Aman

ClInter

Wrkst

BupWkst

Lwaivers

Review

CC

Comp

TimExt

RDMD

Review Date

CorrectionsMade

MemoNOtes

TNDNotes

STWNotes

DecAccNotes

ConProNotes

CoDNotes

BegDatNotes

DurationNotes

CPNotes

ContributionNotes

FIMFNotes

MBPNotes

RpayNotes

OffAccNotes

ReAccNotes

ReErrNotes

AmtNotes

ErrAmtNotes

ICNotes

DmetNotes

StatusNotes

ResAccuteNotes

BenaccuNotes

PETNotes

ComANotes

AuNotes

CplanNotes

DMWUNotes

SUIONotes

SalPreNotes

PdatNotes

Item

4567678

MH

Yes

No - Correction Needed

N/A

No - Correction Needed

No - Correction Not Needed

Yes

N/A

Yes

N/A

No - Correction Needed

1000000

200000

Yes

No - Correction Needed

N/A

Yes

N/A

Yes

N/A

No - Correction Not Needed

Yes

N/A

No - Correction Needed

No - Correction Not Needed

1/30/2019

Yes

dgdd

Item

67890

SG

Yes

No - Correction Not Needed

Yes

No - Correction Not Needed

No - Correction Needed

N/A

Yes

N/A

No - Correction Needed

456667

500000

10000

Yes

N/A

Yes

N/A

Yes

No - Correction Needed

Yes

N/A

Yes

No - Correction Not Needed

Yes

N/A

No - Correction Not Needed

No - Correction Needed

No - Correction Not Needed

1/16/2019

No

fgfgdgdgd

bzdb

xb

fbxb

xb

eytsghsfth

fgfbxb

fbxbb

bbxb

xfbxb

fxgxfxh

fbxxfb

Item

45678

CL

Yes

No - Correction Needed

No - Correction Not Needed

N/A

No - Correction Needed

Yes

N/A

Yes

No - Correction Needed

1500000

200000

Yes

N/A

No - Correction Needed

No - Correction Not Needed

Yes

N/A

No - Correction Needed

Yes

No - Correction Needed

No - Correction Not Needed

2/13/2019

Yes

cvddfg

Item

45678

DG

Yes

No - Correction Not Needed

No - Correction Needed

N/A

Yes

N/A

Yes

700000

50000

Yes

No - Correction Not Needed

No - Correction Needed

Yes

No - Correction Not Needed

Yes

N/A

Yes

8/14/2019

No

cxvxcvxc

Item

45678

DL

Yes

No - Correction Not Needed

N/A

No - Correction Not Needed

No - Correction Needed

Yes

N/A

No - Correction Not Needed

750000

10000

N/A

Yes

No - Correction Needed

No - Correction Not Needed

Yes

No - Correction Needed

Yes

No - Correction Needed

Yes

4/16/2020

Yes

gdfhh

Item

45678

GS

Yes

No - Correction Needed

N/A

No - Correction Not Needed

No - Correction Needed

Yes

No - Correction Needed

300000

2000

N/A

Yes

No - Correction Not Needed

No - Correction Needed

Yes

N/A

Yes

N/A

Yes

No - Correction Needed

Yes

9/24/2020

No

gdfgg

Item

56789

MB

Yes

No - Correction Needed

N/A

No - Correction Not Needed

N/A

No - Correction Needed

Yes

N/A

Yes

No - Correction Needed

Yes

No - Correction Needed

Yes

600000

20000

No - Correction Not Needed

No - Correction Needed

Yes

No - Correction Needed

No - Correction Not Needed

Yes

No - Correction Not Needed

N/A

Yes

No - Correction Needed

No - Correction Not Needed

2/4/2021

No

sdgdsgsd

Item

234567

CL

Yes

No - Correction Not Needed

Yes

No - Correction Needed

N/A

No - Correction Needed

No - Correction Not Needed

Yes

No - Correction Needed

No - Correction Not Needed

Yes

1000000

50000

60000

Yes

No - Correction Not Needed

No - Correction Needed

Yes

N/A

Yes

No - Correction Needed

Yes

No - Correction Not Needed

N/A

Yes

No - Correction Not Needed

Yes

No - Correction Needed

No - Correction Not Needed

1/15/2019

No

sdgsdg

comments

Comment

Comments

comments

COmment

comments

Comments

Item

692877

NB

Yes

No - Correction Not Needed

No - Correction Needed

N/A

Yes

No - Correction Needed

Yes

N/A

Yes

N/A

957.19

N/A

Yes

N/A

Yes

N/A

1/21/2019

No

sdgsdgs

date corrected to reflect earlier onset

i:0#.w|sic\kspierin

ncm consult needed

Item

00325698

TG

1/15/2019

No

ertery

Item

693008

NB

N/A

Yes

N/A

No - Correction Needed

N/A

No - Correction Needed

N/A

1000

N/A

No - Correction Needed

N/A

Yes

N/A

No - Correction Needed

Yes

N/A

No - Correction Needed

N/A

No - Correction Not Needed

1/23/2019

No

eryery

disability date should be 10.1

Item

00323333

TG

1/8/2019

No

eryery

Item

Report (sheet#2)
PREFILLED FIELD	PREFILLED FIELD	PREFILLED FIELD	PREFILLED FIELD	Comes from Raw Data	Comes from Raw Data	Comes from Raw Data	Comes from Raw Data	Comes from Raw Data
Question ID	Category	QUESTIONS	list field	Name	Correctable/Not Correctable	ID	Notes	CorrectionMade
Q.2	TD	Detailed Question Description	TND	MH	No - Correction Needed	4567678	dgdd	Yes
Q.2	TD	Detailed Question Description	TND	SG	No - Correction Not Needed	67890	fgfgdgdgd	No
Q.2	TD	Detailed Question Description	TND	CL	No - Correction Needed	45678	cvddfg	Yes
Q.2	TD	Detailed Question Description	TND	DL	No - Correction Not Needed	45678	gdfhh	Yes
Q.2	TD	Detailed Question Description	TND	GS	No - Correction Needed	45678	gdfgg	No
Q.2	TD	Detailed Question Description	TND	MB	No - Correction Needed	56789	sdgdsgsd	No
Q.2	TD	Detailed Question Description	TND	NB	No - Correction Not Needed	692877	sdgsdgs	No
Q.3	TD	Detailed Question Description	STW
Q.3	TD	Detailed Question Description	STW
Q.3	TD	Detailed Question Description	STW
Q.3	TD	Detailed Question Description	STW
Q.3	TD	Detailed Question Description	STW
Q.3	TD	Detailed Question Description	STW
Q.3	TD	Detailed Question Description	STW
Q.3	TD	Detailed Question Description	STW
Q.5	DA	Detailed Question Description	DecAcc
	DA	Detailed Question Description	DecAcc
	DA	Detailed Question Description	DecAcc
Q.6	DA	Detailed Question Description	ConPro
Q.7	DA	Detailed Question Description	CoD
Q.8	PFA	Detailed Question Description	BegDat
Q.9	PFA	Detailed Question Description	Duration
	PFA	Detailed Question Description	Duration
Q.10	PFA	Detailed Question Description	CP
	PFA	Detailed Question Description	CP
Q.12	PFA	Detailed Question Description	FIMF
	PFA	Detailed Question Description	FIMF
Q.13	PFA	Detailed Question Description	MBP
	PFA	Detailed Question Description	Rpay
Q.14	PFA	Detailed Question Description	OffAcc
	PFA	Detailed Question Description	OffAcc
Q.15	PFA	Detailed Question Description	ReAcc

DanteAmor · Feb 15, 2019

Try this for all the questions

Code:

Sub Fill_Report()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim answer As Range
    Dim q As Long, j As Long
    
    Application.ScreenUpdating = False
    
    Set ws1 = Sheets("Rawdata")
    Set ws2 = Sheets("Report")
    
    'clear old report data
    ws2.Rows("3:" & Rows.Count).ClearContents
    ws2.ListObjects("Report").Resize Range("$A$2:$I$3")
    
    q = 1   'Initial question number
    j = 3   'Initial row target
    
    'Column C initial question To column AR end question
    For i = Columns("C").Column To Columns("AR").Column
        For Each answer In ws1.Range("Table_Rawdata[" & ws1.Cells(1, i).Value & "]").Cells
            If answer.Value Like "No*" Then
                ws2.Cells(j, "A").Value = "Q." & q                                                      'question ID
                ws2.Cells(j, "B").Value = "Category"                                                    'category
                ws2.Cells(j, "C").Value = "Deatiled Question Description"                               'question
                ws2.Cells(j, "D").Value = ws1.Cells(1, i).Value                                         'list field
                ws2.Cells(j, "E").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[Name]]").Column)  'name
                ws2.Cells(j, "F").Value = answer.Value                                                  'Correctable/Not Correctable
                ws2.Cells(j, "G").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[ID]]").Column)    'ID
                ws2.Cells(j, "H").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[TNDNotes]]").Column)  'Notes
                ws2.Cells(j, "I").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[CorrectionsMade]]").Column)   'CorrectionMade
                j = j + 1
            End If
        Next
        q = q + 1
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub

Megha1484 · Feb 15, 2019

Thanks for the quick reply, really appreciate your help. I ran the code and it works till ws2.row("3:" & Rows.Count).ClearContents. After that it gives me a "Run time error '9' Subscript out of range err"

DanteAmor said:

Try this for all the questions

Code:

Sub Fill_Report()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim answer As Range
    Dim q As Long, j As Long
    
    Application.ScreenUpdating = False
    
    Set ws1 = Sheets("Rawdata")
    Set ws2 = Sheets("Report")
    
    'clear old report data
    ws2.Rows("3:" & Rows.Count).ClearContents
    ws2.ListObjects("Report").Resize Range("$A$2:$I$3")
    
    q = 1   'Initial question number
    j = 3   'Initial row target
    
    'Column C initial question To column AR end question
    For i = Columns("C").Column To Columns("AR").Column
        For Each answer In ws1.Range("Table_Rawdata[" & ws1.Cells(1, i).Value & "]").Cells
            If answer.Value Like "No*" Then
                ws2.Cells(j, "A").Value = "Q." & q                                                      'question ID
                ws2.Cells(j, "B").Value = "Category"                                                    'category
                ws2.Cells(j, "C").Value = "Deatiled Question Description"                               'question
                ws2.Cells(j, "D").Value = ws1.Cells(1, i).Value                                         'list field
                ws2.Cells(j, "E").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[Name]]").Column)  'name
                ws2.Cells(j, "F").Value = answer.Value                                                  'Correctable/Not Correctable
                ws2.Cells(j, "G").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[ID]]").Column)    'ID
                ws2.Cells(j, "H").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[TNDNotes]]").Column)  'Notes
                ws2.Cells(j, "I").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[CorrectionsMade]]").Column)   'CorrectionMade
                j = j + 1
            End If
        Next
        q = q + 1
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub

DanteAmor · Feb 15, 2019

Remove this line and try again

Code:

ws2.ListObjects("Report").Resize Range("$A$2:$I$3")

Megha1484 · Feb 15, 2019

Another error. Thanks for being so patient with me.

Megha1484 · Feb 15, 2019

sorry, the image did not come through.

Run-time error'1004' Method 'Rang' of Object'_Worksheet' failed on line

For Each answer In ws1.Range("Table_Rawdata[" & ws1.Cells(1, i).Value & "]").Cells

DanteAmor · Feb 15, 2019

Try this,

Sorry but, I'm trying to guess where your "Table_Rawdata" and "Report" tables are. If you have another problem, You could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

Code:

Sub Fill_Report()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim answer As Range
    Dim q As Long, j As Long, initial As Long
    
    Application.ScreenUpdating = False
    
    Set ws1 = Sheets("Rawdata")
    Set ws2 = Sheets("Report")
    
    'clear old report data
    ws2.Rows("3:" & Rows.Count).ClearContents
    'ws2.ListObjects("Report").Resize Range("$A$2:$I$3")
    
    q = 1   'Initial question number
    j = 3   'Initial row target
    
    'Column C initial question To column AR end question
    initial = ws1.Range("Table_Rawdata[#All]").Cells(1, 1).Row
    For i = Columns("C").Column To Columns("AR").Column
        For Each answer In ws1.Range("Table_Rawdata[" & ws1.Cells(initial, i).Value & "]").Cells
            If answer.Value Like "No*" Then
                ws2.Cells(j, "A").Value = "Q." & q                                                      'question ID
                ws2.Cells(j, "B").Value = "Category"                                                    'category
                ws2.Cells(j, "C").Value = "Deatiled Question Description"                               'question
                ws2.Cells(j, "D").Value = ws1.Cells(1, i).Value                                         'list field
                ws2.Cells(j, "E").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[Name]]").Column)  'name
                ws2.Cells(j, "F").Value = answer.Value                                                  'Correctable/Not Correctable
                ws2.Cells(j, "G").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[ID]]").Column)    'ID
                ws2.Cells(j, "H").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[TNDNotes]]").Column)  'Notes
                ws2.Cells(j, "I").Value = ws1.Cells(answer.Row, Range("Table_Rawdata[[CorrectionsMade]]").Column)   'CorrectionMade
                j = j + 1
            End If
        Next
        q = q + 1
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub

Megha1484 · Feb 15, 2019

Thanks Dante! Here is the link.

https://app.box.com/s/5wpgcr46kvg9od3153iujoorl2qhpfe8

DanteAmor · Feb 15, 2019

In your original code the name of your table is "Table_Rawdata" and now it is "Table1".
I have problems with the ID column, but it is already solved.
Try this:

Code:

Sub Fill_Report()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim answer As Range
    Dim q As Long, j As Long, initial As Long
    
    Application.ScreenUpdating = False
    
    Set ws1 = Sheets("Rawdata")
    Set ws2 = Sheets("Report")
    
    'clear old report data
    ws2.Rows("3:" & Rows.Count).ClearContents
    'ws2.ListObjects("Report").Resize Range("$A$2:$I$3")
    
    q = 1   'Initial question number
    j = 3   'Initial row target
    
    'Column C initial question To column AR end question
    initial = ws1.Range("[COLOR=#ff0000]Table1[/COLOR][#All]").Cells(1, 1).Row
    For i = Columns("C").Column To Columns("AR").Column
        For Each answer In ws1.Range("[COLOR=#ff0000]Table1[/COLOR][" & ws1.Cells(initial, i).Value & "]").Cells
            If answer.Value Like "No*" Then
                ws2.Cells(j, "A").Value = "Q." & q                                                      'question ID
                ws2.Cells(j, "B").Value = "Category"                                                    'category
                ws2.Cells(j, "C").Value = "Deatiled Question Description"                               'question
                ws2.Cells(j, "D").Value = ws1.Cells(1, i).Value                                         'list field
                ws2.Cells(j, "E").Value = ws1.Cells(answer.Row, Range("Table1[[Name]]").Column)  'name
                ws2.Cells(j, "F").Value = answer.Value                                                  'Correctable/Not Correctable
                ws2.Cells(j, "G").Value = [COLOR=#ff0000]ws1.Cells(answer.Row, 1)    'ID[/COLOR]
                ws2.Cells(j, "H").Value = ws1.Cells(answer.Row, Range("Table1[[TNDNotes]]").Column)  'Notes
                ws2.Cells(j, "I").Value = ws1.Cells(answer.Row, Range("Table1[[CorrectionsMade]]").Column)   'CorrectionMade
                j = j + 1
            End If
        Next
        q = q + 1
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub

Review the file below
https://www.dropbox.com/s/4iur739oaantsnk/Correrrreport dam.xlsm?dl=0

Megha1484 · Feb 15, 2019

Many, many thanks! I will try it out on first thing on Tuesday. I will keep you.posted!

DanteAmor said:

In your original code the name of your table is "Table_Rawdata" and now it is "Table1".
I have problems with the ID column, but it is already solved.
Try this:

Code:

Sub Fill_Report()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim answer As Range
    Dim q As Long, j As Long, initial As Long
    
    Application.ScreenUpdating = False
    
    Set ws1 = Sheets("Rawdata")
    Set ws2 = Sheets("Report")
    
    'clear old report data
    ws2.Rows("3:" & Rows.Count).ClearContents
    'ws2.ListObjects("Report").Resize Range("$A$2:$I$3")
    
    q = 1   'Initial question number
    j = 3   'Initial row target
    
    'Column C initial question To column AR end question
    initial = ws1.Range("[COLOR=#ff0000]Table1[/COLOR][#All]").Cells(1, 1).Row
    For i = Columns("C").Column To Columns("AR").Column
        For Each answer In ws1.Range("[COLOR=#ff0000]Table1[/COLOR][" & ws1.Cells(initial, i).Value & "]").Cells
            If answer.Value Like "No*" Then
                ws2.Cells(j, "A").Value = "Q." & q                                                      'question ID
                ws2.Cells(j, "B").Value = "Category"                                                    'category
                ws2.Cells(j, "C").Value = "Deatiled Question Description"                               'question
                ws2.Cells(j, "D").Value = ws1.Cells(1, i).Value                                         'list field
                ws2.Cells(j, "E").Value = ws1.Cells(answer.Row, Range("Table1[[Name]]").Column)  'name
                ws2.Cells(j, "F").Value = answer.Value                                                  'Correctable/Not Correctable
                ws2.Cells(j, "G").Value = [COLOR=#ff0000]ws1.Cells(answer.Row, 1)    'ID[/COLOR]
                ws2.Cells(j, "H").Value = ws1.Cells(answer.Row, Range("Table1[[TNDNotes]]").Column)  'Notes
                ws2.Cells(j, "I").Value = ws1.Cells(answer.Row, Range("Table1[[CorrectionsMade]]").Column)   'CorrectionMade
                j = j + 1
            End If
        Next
        q = q + 1
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub

Review the file below
https://www.dropbox.com/s/4iur739oaantsnk/Correrrreport dam.xlsm?dl=0

Need Help with VBA Code

Megha1484

New Member

Excel Facts

DanteAmor

Well-known Member

Megha1484

New Member

DanteAmor

Well-known Member

Megha1484

New Member

Megha1484

New Member

DanteAmor

Well-known Member

Megha1484

New Member

DanteAmor

Well-known Member

Megha1484

New Member

Similar threads

Forum statistics

Share this page

Need Help with VBA Code

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock