Please Help me With Extracting only the necessary columns from one file to another

leeb91

New Member
Joined
May 22, 2015
Messages
20
Hi,
I am currently having difficulty writing out some VBA scripts to basically extract the columns that I need into the new file and save it separately.
Code below is what I have written but this doesn't work at all. Since I am new to vba programming can anyone enlighten me?
Here is what I have to do
1. I have 2 files, one called Template and the others that go by company name(I have about 200 of them)
2. Each data sheet from my clients have column headings that I don't necessarily need and only have to extract the columns and paste it into a new file that keeps
Template file's Column headings and from there the data is added to the sheet and saves.

Sub Clean()

Dim dbook As Workbook
Dim rngCri As Range
Dim rngTemp As Range
Dim N As Long
Dim wb As Workbook

N = 1
Do
tfile = "c:\" & "(" & N & ")" & ".xlsx"
tfile1 = "c:\" & "Original" & "(" & N & ")" & ".xlsm"
Set rngCri = ThisWorkbook.Sheets(1).Range("a1")
If InStr(1, rngCri.Text, "Status") Or InStr(1, rngCri.Text, "Matter Status") Or InStr(1, rngCri.Text, "Resolution") Or _
InStr(1, rngCri.Text, "Resolution Date") Then
rngCri.Text = "Claim_Status"
ElseIf InStr(1, celltxt, "Disease") Then
rngCri = "Disease_Type"
End If

On Error GoTo K:
Set dbook = Workbooks.Open(Filename:=tfile)

Set rngTemp = Range("a1")
Set celltxt1 = rngTemp.Text

Do
If InStr(1, celltxt1, "Status") Or InStr(1, celltxt1, "Matter Status") Or InStr(1, celltxt1, "Resolution") Or _
InStr(1, celltxt, "Resolution Date") Then
rngCri = "Claim_Status"
ElseIf InStr(1, celltxt1, "Disease") Then
rngCri = "Disease_Type"
End If
Set rngTemp = rngTemp.Offset(0, 1)
If rngTemp = "" Then Exit Do
Loop

Do
dbook.Activate
Set rngTemp = Range(Range("a1").Range("a1").End(xlToRight))
Set rngF = rngTemp.Find(What:=rngCri, LookAt:=xlWhole)

If rngF Is Nothing Then
Else
If rngF.Offset(1, 0) = "" Then
Else
Range(rngF.Offset(1, 0), rngF.Offset(1, 0).End(xlDown)).Copy
ThisWorkbook.Activate
rngCri.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
End If

If rngCri = "" Then Exit Do
Loop
Application.DisplayAlerts = False
dbook.Close True
ThisWorkbook.Save
ActiveWorkbook.SaveAs Filename:=tfile1

N = N + 1
If N = 6 Then Exit Do
Loop
K:
End Sub
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Forum statistics

Threads
1,215,351
Messages
6,124,445
Members
449,160
Latest member
nikijon

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top