Using multiple Dim path/file in 1 sub - file

Moving code from saving on a network drive to SharePoint.
The fist bit of code works but the rest doesn't.
It is a lengthy bit of code that repeats its self but the idea is it will copy the worksheet between 1-5 times depending how many are needed and then name each one differently (based on cell value) and then save on SharePoint.
It did create a folder when saving on the local drive but I removed that as it seems impossible for SharePoint.
The problem seems to be having multiple Dim Path / Dim Filename so I tried changing it to Dim Path1/Dim File1 but that doesn't work
Example of info in c2 "518 Non-Conformance Report Major Other1"
Any help would be great.
Sub Saveme()
Workbooks("log").Unprotect Password:="****"
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Sheet10").Visible = True
If ThisWorkbook.Sheets("Sheet10").Range("C10").Value <> "" Then
ThisWorkbook.Sheets("Non Con 1").Visible = True
ThisWorkbook.Sheets("Non con 1").Copy
ActiveWorkbook.Sheets("Non con 1").Range("C2:Q8").Select
Selection.Copy
ActiveSheet.Range("C2:Q8").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("F2:Q2").Merge
ActiveSheet.Range("C2:E2").Merge
ActiveSheet.Range("N3:O3").Merge
ActiveSheet.Range("J3:K3").Merge
ActiveSheet.Range("H3:I3").Merge
ActiveSheet.Range("E3:F3").Merge
ActiveSheet.Range("C5:Q5").Merge
ActiveSheet.Range("D6:Q6").Merge
ActiveSheet.Range("D7:Q7").Merge
ActiveSheet.Range("D8:Q8").Merge
ActiveSheet.Protect Password:="****", AllowFormattingRows:=True
Dim Path As String
Dim filename As String
Path = "https://Company.sharepoint.com/teams/folder/Documents/Here/Raised NCFs/"
filename = ThisWorkbook.Sheets("Sheet10").Range("C2")
ActiveWorkbook.SaveAs filename:=Path & filename & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close
ThisWorkbook.Sheets("Non Con 1").Visible = False
End If
On Error Resume Next
If ThisWorkbook.Sheets("Sheet10").Range("C11").Value <> "" Then
ThisWorkbook.Sheets("Non Con 2").Visible = True
ThisWorkbook.Sheets("Non con 2").Copy
ActiveWorkbook.Sheets("Non con 2").Range("C2:Q8").Select
Selection.Copy
ActiveSheet.Range("C2:Q8").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("F2:Q2").Merge
ActiveSheet.Range("C2:E2").Merge
ActiveSheet.Range("N3:O3").Merge
ActiveSheet.Range("J3:K3").Merge
ActiveSheet.Range("H3:I3").Merge
ActiveSheet.Range("E3:F3").Merge
ActiveSheet.Range("C5:Q5").Merge
ActiveSheet.Range("D6:Q6").Merge
ActiveSheet.Range("D7:Q7").Merge
ActiveSheet.Range("D8:Q8").Merge
ActiveSheet.Protect Password:="****", AllowFormattingRows:=True
Dim Path1 As String
Dim filename1 As String
Path1 = "https://Company.sharepoint.com/teams/folder/Documents/Here/Raised NCFs/"
filename1 = ThisWorkbook.Sheets("Sheet10").Range("C3")
ActiveWorkbook.SaveAs filename:=Path1 & filename1 & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=FalseActiveWorkbook.Close
ThisWorkbook.Sheets("Non Con 2").Visible = False
End If
On Error Resume Next
If ThisWorkbook.Sheets("Sheet10").Range("C12").Value <> "" Then
ThisWorkbook.Sheets("Non Con 3").Visible = True
ThisWorkbook.Sheets("Non con 3").Copy
ActiveWorkbook.Sheets("Non con 3").Range("C2:Q8").Select
Selection.Copy
ActiveSheet.Range("C2:Q8").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("F2:Q2").Merge
ActiveSheet.Range("C2:E2").Merge
ActiveSheet.Range("N3:O3").Merge
ActiveSheet.Range("J3:K3").Merge
ActiveSheet.Range("H3:I3").Merge
ActiveSheet.Range("E3:F3").Merge
ActiveSheet.Range("C5:Q5").Merge
ActiveSheet.Range("D6:Q6").Merge
ActiveSheet.Range("D7:Q7").Merge
ActiveSheet.Range("D8:Q8").Merge
ActiveSheet.Protect Password:="****", AllowFormattingRows:=True
Dim Path3 As String
Dim filename3 As String
Path3 = "https://Company.sharepoint.com/teams/folder/Documents/Here/Raised NCFs/"
filename3 = ThisWorkbook.Sheets("Sheet10").Range("C4")
ActiveWorkbook.SaveAs filename:=Path3 & filename3 & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=FalseActiveWorkbook.Close
ThisWorkbook.Sheets("Non Con 3").Visible = False
End If
On Error Resume Next
If ThisWorkbook.Sheets("Sheet10").Range("C13").Value <> "" Then
ThisWorkbook.Sheets("Non Con 4").Visible = True
ThisWorkbook.Sheets("Non con 4").Copy
ActiveWorkbook.Sheets("Non con 4").Range("C2:Q8").Select
Selection.Copy
ActiveSheet.Range("C2:Q8").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("F2:Q2").Merge
ActiveSheet.Range("C2:E2").Merge
ActiveSheet.Range("N3:O3").Merge
ActiveSheet.Range("J3:K3").Merge
ActiveSheet.Range("H3:I3").Merge
ActiveSheet.Range("E3:F3").Merge
ActiveSheet.Range("C5:Q5").Merge
ActiveSheet.Range("D6:Q6").Merge
ActiveSheet.Range("D7:Q7").Merge
ActiveSheet.Range("D8:Q8").Merge
ActiveSheet.Protect Password:="****", AllowFormattingRows:=True
Dim Path4 As String
Dim filename4 As String
Path4 = "https://Company.sharepoint.com/teams/folder/Documents/Here/Raised NCFs/"
filename4 = ThisWorkbook.Sheets("Sheet10").Range("C5")
ActiveWorkbook.SaveAs filename:=Path4 & filename4 & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=FalseActiveWorkbook.Close
ThisWorkbook.Sheets("Non Con 4").Visible = False
End If
On Error Resume Next
If ThisWorkbook.Sheets("Sheet10").Range("C14").Value <> "" Then
ThisWorkbook.Sheets("Non Con 5").Visible = True
ThisWorkbook.Sheets("Non con 5").Copy
ActiveWorkbook.Sheets("Non con 5").Range("C2:Q8").Select
Selection.Copy
ActiveSheet.Range("C2:Q8").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("F2:Q2").Merge
ActiveSheet.Range("C2:E2").Merge
ActiveSheet.Range("N3:O3").Merge
ActiveSheet.Range("J3:K3").Merge
ActiveSheet.Range("H3:I3").Merge
ActiveSheet.Range("E3:F3").Merge
ActiveSheet.Range("C5:Q5").Merge
ActiveSheet.Range("D6:Q6").Merge
ActiveSheet.Range("D7:Q7").Merge
ActiveSheet.Range("D8:Q8").Merge
ActiveSheet.Protect Password:="****", AllowFormattingRows:=True
Dim Path5 As String
Dim filename5 As String
Path5 = "https://Company.sharepoint.com/teams/folder/Documents/Here/Raised NCFs/"
filename5 = ThisWorkbook.Sheets("Sheet10").Range("C6")
ActiveWorkbook.SaveAs filename:=Path5 & filename5 & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=FalseActiveWorkbook.Close
ThisWorkbook.Sheets("Non Con 5").Visible = False
End If
On Error Resume Next
ThisWorkbook.Sheets("Sheet10").Visible = False
Workbooks("log").Protect Password:="QA1234"
Call Email
End Sub
It did work before trying to use with sharepoint location.
The problem seems to be having multiple Dim Path / Dim Filename so I tried changing it to Dim Path1/Dim File1 but that doesn't work

Related

Find and Replace is not woking in Macro

The below macro is creating a little problem, basically those text which are getting replaced are not getting replaced properly. First condition find * and replace with "Opertaions" is working fine, however on the second condition when it is replacing "Not Met" with Operation is not working.
Click to see Excel Imgae Link
Sub Recon()
Dim c As Range
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
For Each c In Source.Range("G2:G" & Source.Cells(Rows.Count, 1).End(xlUp).Row)
If c = "Not Met" Then
c.EntireRow.Copy
Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Target.Range("G:G").Replace What:="*", Replacement:="Opertaion", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Target.Range("G1").Value = "Issue Category"
End If
Next c
' There is some problem, with the below code in place of changing "Not Met" it is changing something else.
For Each c In Source.Range("H2:H" & Source.Cells(Rows.Count, 1).End(xlUp).Row)
If c = "Not Met" Then
c.EntireRow.Copy
Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Target.Range("G:G").Replace What:="Not Met", Replacement:="Operation", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Target.Range("G1").Value = "Issue Category"
End If
Next c
For Each c In Source.Range("I2:I" & Source.Cells(Rows.Count, 1).End(xlUp).Row)
If c = "Not Met" Then
c.EntireRow.Copy
Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Target.Range("G:G").Replace What:="Not Met", Replacement:="People", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Target.Range("G1").Value = "Issue Category"
End If
Next c
For Each c In Source.Range("J2:J" & Source.Cells(Rows.Count, 1).End(xlUp).Row)
If c = "Not Met" Then
c.EntireRow.Copy
Target.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Target.Range("G:G").Replace What:="Not Met", Replacement:="Customer", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Target.Range("G1").Value = "Issue Category"
End If
Next c
Target.Range("H2:N1000").ClearContents
End Sub

VBA code to paste data from multiple workbooks into template by changing Pivot Fields

Wrote 3 different codes and Called them via Control Box in VBA, so now I've to select Root Account and Click One Button to create a report Single Account.
Is there a way to create such files for 50-100 accounts where all Root Account names are under Column J and Year under Column 2 (We've only 2 years, 2021 and 2022) but multiple account names in Column J
I've called all 4 Macros via Command Button, so now we've click only once to create file for one account but I need one click to create 100 accounts. Is it possible in any way.
Option Explicit
**'TO CHANGE PIVOT FIELDS (ROOT ACCOUNT & YEAR) IN ALL 4 MASTER FILES (ALL FILES HAVING MULTIPLE PIVOT TABLES AND ALL PIVOTS HAVING ACCOUNT NAME AND YEAR)**
Sub Account_Name_And_Year()
Dim workbookNames As Variant
workbookNames = Array("Boo1.xlsm", "Boo2.xlsm", "Boo3.xlsm", "Book4.xlsm") **'DEFINED WORKBOOK NAMES AS ARRAY**
Dim i As Long
For i = LBound(workbookNames) To UBound(workbookNames)
Dim wb As Workbook
Set wb = Workbooks(workbookNames(i))
Dim ws As Worksheet
Set ws = wb.Worksheets("Reports")
Dim rootAccount As String
rootAccount = ws.Cells(1, 10).Value **'IT'LL CHANGE PIVOT FIELD ROOT ACCOUNT AS CELL RANGE ("J1") IN ALL 4 FILES"**
Dim year As String
year = ws.Cells(1, 11).Value **'IT'LLL CHANGE PIVOT FIELD YEAR AS CELL RANGE ("K1") IN ALL 4 FILES"**
Dim pt As PivotTable
For Each pt In ws.PivotTables
With pt
With .PivotFields("Root Account") **'CHANGES PIVOT FIELD ROOT ACCOUNT ALL 4 MASTER FILES**
.CurrentPage = rootAccount
End With
With .PivotFields("Year") **'CHANGES PIVOT FIELD YEAR IN ALL 4 MASTER FILES**
.CurrentPage = year
End With
End With
Next pt
Next i
End Sub
**************************************************************************************************
**'ONCE PIVOT FIELDS (ROOT ACCOUNT & YEAR) CHANGES, COPY DATA FROM ALL PIVOT TABLES IN ALL 4 MASTER FILES AND PASTE IN TEMP FILE, SHEET 2021**
Sub Data_2021()
Dim Book1 As Workbook
Dim Book2 As Workbook
Dim Book3 As Workbook
Dim Book4 As Workbook
Dim Temp As Workbook
Set Book1 = Workbooks.Open("C:\New Folder\Boo1.xlsm")
Set Book2 = Workbooks.Open("C:\New Folder\Boo2.xlsm")
Set Book3 = Workbooks.Open("C:\New Folder\Boo3.xlsm")
Set Book4 = Workbooks.Open("C:\New Folder\Boo4.xlsm")
Set Temp = Workbooks.Open("C:\New Folder\Template_File.xlsm")
**'COPY DATA FROM ALL 4 WORKBOOKS AND PASTE IN DATA (2021) SHEET**
Book1.Sheets("Analysis").Range("A13:M71").Copy
Temp.Sheets("Data (2021)").Range("B4").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book2.Sheets("Analysis").Range("S17:W17").Copy
Temp.Sheets("Data (2021)").Range("Z21").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book3.Sheets("Analysis").Range("D12:H12").Copy
Temp.Sheets("Data (2021)").Range("Z36").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book4.Sheets("Analysis").Range("B5:B15").Copy
Temp.Sheets("Data(2021)").Range("X16").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=True
Workbooks("Boo1.xlsm").Activate
Sheets("Analysis").Activate
Range("K2").Activate
Cells(2, 11) = "2022"
End Sub""
**************************************************************************************************
**'THEN AGAIN RUN MACRO Account_Name_And_Year() TO CHANGE YEAR TO 2022 AND UPDATE ALL PIVOT TABLES IN ALL 4 MASTER FILES**
**'COPY DATA FROM ALL PIVOTS FROM ALL 4 MASTER FILES AND PASTE IN TEMP FILE, SHEET 2**
Sub Data_2022()
Dim Book1 As Workbook
Dim Book2 As Workbook
Dim Book3 As Workbook
Dim Book4 As Workbook
Dim Temp As Workbook
Dim FName As String
Dim Path As String
Application.DisplayAlerts = False
Set Book1 = Workbooks.Open("C:\New Folder\Boo1.xlsm")
Set Book2 = Workbooks.Open("C:\New Folder\Boo2.xlsm")
Set Book3 = Workbooks.Open("C:\New Folder\Boo3.xlsm")
Set Book4 = Workbooks.Open("C:\New Folder\Book4.xlsm")
Set Temp = Workbooks.Open("C:\New Folder\Template_File.xlsm")
Book1.Sheets("Analysis").Range("J1").Copy
Temp.Sheets("Data").Range("B1").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book2.Sheets("Analysis").Range("B17:B47").Copy
Temp.Sheets("Data").Range("T5").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book3.Sheets("Analysis").Range("B12:M12").Copy
Temp.Sheets("Data").Range("X37").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book4.Sheets("Analysis").Range("B5:B15").Copy
Temp.Sheets("Data").Range("X16").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=True
Range("A1").Activate
ActiveWorkbook.RefreshAll
Sheets("PPT").Activate
Range("A1").Activate
Path = "C:\New Folder\New folder\"
FName = Range("B1") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=Path & FName
Sheets("PPT").Activate
Application.DisplayAlerts = True
MsgBox "COST ACTUALS REPORT IS CREATED FOR THIS ACCOUNT, PLEASE CLICK ON CREATE_PPT FOR POWERPOINT PRESENTATION"
Workbooks("Boo1.xlsm").Sheets("Analysis").Range("K1").Activate
End Sub

Vlookup Col_Index_Number by Header based on Array iteration?

I am running into an issue with my current code - I am hoping someone can assist:
Issue: I am trying to do a Vlookup from Workbook "ABC". The issue is, I am trying to change the VLOOKUP Col_Index_Number based on a header on workbook ABC...
So for example: For MyArray "Food" I am looking to Vlookup Column_Index_Num for "Food-Mexican" Column on workbook ABC, For MyArray Appetizers, I am looking to Vlookup Column_Index-Num for "Appetizers-American"...
Additionally, the columns will not always be in the same place for each report so it has to be based on the row 1 header of ABC workbook.
Also, sometimes the Array iteration might be skipped, if say for example, "Non-AlcoholicDrinks" is not found.
Sub WIP()
Dim wb As Workbook
Dim wsMain As Worksheet
Dim wsLookup As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim rFind1 As Range
Dim rFind2 As Range
Dim rFind3 As Range
Dim MyArray As Variant
Dim LookupHeaders As Variant
Dim LookupHeaders2 As Variant
Dim LR As Long
Dim i As Long
Dim PriceCol As Long
Dim pricecol2 As Long
Dim LastColumn As Long
Dim LastColumn2 As Long
Dim LastColumn3 As Long
Dim LastColumn4 As Long
Dim IndexCol As Long
'Unformatted Price Row
Sheets("Consolidate List").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("J:N").Delete
Columns("J:J").Select
ActiveWindow.FreezePanes = True
Range("H2").Select
ActiveCell.FormulaR1C1 = "New Price"
ActiveCell.Interior.ColorIndex = 22
Range("H3:H" & LR).Formula = "=VLOOKUP(RC[-7],'Connect Report'!C[-7]:C[-6],2,FALSE)"
ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("I2").Select
ActiveCell.FormulaR1C1 = "Difference"
ActiveCell.Interior.ColorIndex = 22
Range("I3:I" & LR).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Set wb = ActiveWorkbook
Sheets("Consolidate List").Select
Set wsMain = wb.ActiveSheet
Set wsLookup = wb.Sheets("Connect Report") '<-- Change to correct sheet name for the Lookup sheet
LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
MyArray = Array("US", "SPAIN", "California")
LookupHeaders = Array("TTIER", "Time333", "Round6")
LookupHeaders2 = Array("TELLER5", "Fly7", "Mine4")
For i = LBound(MyArray) To UBound(MyArray)
With wsMain.Rows(1)
Set rFind1 = .Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind1 Is Nothing Then
Set rng = rFind1.Offset(1).Resize(, 8)
PriceCol = Application.Match("New Opposed Price", rng, 0)
LastColumn = rFind1.Column + PriceCol
If wsMain.Cells(rng.Row, LastColumn) <> "New Opposed Price" Then
wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng.Row, LastColumn).Value = "New Opposed Price"
wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
LastColumn2 = LastColumn + 1
wsMain.Columns(LastColumn2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng.Row, LastColumn2).Value = "Difference"
wsMain.Cells(rng.Row, LastColumn2).Interior.ColorIndex = 22
Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlWhole)
If Not rFind2 Is Nothing Then
IndexCol = rFind2.Column
wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"
wsMain.Cells(rng.Row + 1, LastColumn2).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
Else
MsgBox "Excel could not find " & LookupHeaders(i) & " in the lookup table."
End If
Set rng2 = rFind1.Offset(1).Resize(, 8)
pricecol2 = Application.Match("New Muted Price", rng, 0)
LastColumn3 = rFind1.Column + pricecol2
If wsMain.Cells(rng.Row, LastColumn3) <> "New Muted Price" Then
wsMain.Columns(LastColumn3).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng2.Row, LastColumn3).Value = "New Muted Price"
wsMain.Cells(rng2.Row, LastColumn3).Interior.ColorIndex = 22
LastColumn4 = LastColumn3 + 1
wsMain.Columns(LastColumn4).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng2.Row, LastColumn4).Value = "Difference"
wsMain.Cells(rng2.Row, LastColumn4).Interior.ColorIndex = 22
End If
Set rFind3 = wsLookup.Rows(1).Find(LookupHeaders2(i), wsLookup.Range("A1"), xlValues, xlWhole)
If Not rFind3 Is Nothing Then
IndexCol = rFind3.Column
wsMain.Cells(rng2.Row + 1, LastColumn3).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng2.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"
wsMain.Cells(rng2.Row + 1, LastColumn4).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
Else
MsgBox "Excel could not find " & LookupHeaders2(i) & " in the lookup table."
End If
End If
End If
End With
Next i
End Sub
Can anyone help with this? I am completely lost on how to resolve this issue. Also, I am hoping that I described the issue clearly... it is quite confusing.

I believe something like this should work for you. Give it a try and let me know.
Sub tgr()
Dim wb As Workbook
Dim wsMain As Worksheet
Dim wsLookup As Worksheet
Dim rng As Range
Dim rFind1 As Range
Dim rFind2 As Range
Dim MyArray As Variant
Dim LookupHeaders As Variant
Dim LR As Long
Dim i As Long
Dim PriceCol As Long
Dim LastColumn As Long
Set wb = ActiveWorkbook
Set wsMain = wb.ActiveSheet
Set wsLookup = wb.Sheets("ABC") '<-- Change to correct sheet name for the Lookup sheet
LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
MyArray = Array("TEST", "Food", "Non-AlcoholicDrinks", "Appetizers", "Alcoholic Drinks")
LookupHeaders = Array("TestHeader", "FoodHeader", "Non-AlcoholicDrinksHeader", "AppetizersHeader", "Alcoholic DrinksHeader")
For i = LBound(MyArray) To UBound(MyArray)
Set rFind1 = wsMain.Rows(1).Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind1 Is Nothing Then
Set rng = rFind1.Offset(1).Resize(, 8)
PriceCol = Application.Match("Price", rng, 0)
LastColumn = rFind1.Column + PriceCol
If wsMain.Cells(rng.Row, LastColumn) <> "Difference" Then
wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng.Row, LastColumn).Value = "Difference"
wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
End If
Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlPart)
If Not rFind2 Is Nothing Then
With wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2)
.Formula = "=VLOOKUP(A" & rng.Row + 1 & "," & wsLookup.Range("A:AL").Address(External:=True) & "," & rFind2.Column & ",FALSE)"
.Value = .Value 'Convert to values
End With
End If
End If
Next i
End Sub

This is a User Defined Function I've wrote to find the range of based on column header, it uses .find method to find the target cells. Works well if you column titles are are the top of your worksheet.
I hope this solves your problem, you could just findout the target column, by using .column on the range returned.
'define a range by looking for a specific text title, and return all the cells to the lastrow of the sheet as a range
Private Function defineColRange(ByVal targetWorkSheet As Worksheet, ByVal targetValue As String, _
Optional ByVal visibleOnly As Boolean, Optional ByVal rtnNoTitle As Boolean, _
Optional ByVal searchByColumn, Optional ByVal searchBackwards) As Range
Dim targetlastRow As Long
Dim targetlastCol As Long
Dim returnRange As Range
Dim findTarget As Range
'default visible only mode off
If IsMissing(visibleOnly) Then
visibleOnly = False
End If
If IsMissing(rtnNoTitle) Then 'Don't return title cell in the range returned
rtnNoTitle = False
End If
If IsMissing(searchByColumn) Then 'Search vertically by column, instead of by rows
searchByColumn = False
End If
If IsMissing(searchBackwards) Then 'Search backwards by rows
searchBackwards = False
End If
'test if targetWorkSheet is not empty
If targetWorkSheet Is Nothing Then
MsgBox ("Worksheet pass failed!"), vbExclamation
Exit Function
End If
targetWorkSheet.Activate
targetlastRow = targetWorkSheet.UsedRange.Find(What:="*", _
after:=Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
Searchorder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
targetlastCol = targetWorkSheet.UsedRange.Find(What:="*", _
after:=Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
Searchorder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'find the range
If searchByColumn = True Then
Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
ElseIf searchBackwards = True Then
Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, targetlastCol), _
LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False)
Else
Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
End If
If findTarget Is Nothing Then
Debug.Print ("Did not find columne title """ & targetValue & ""), vbExclamation
Exit Function
Else
Dim tRow, tCol As Long
tRow = findTarget.Row
tCol = findTarget.Column
On Error Resume Next
If visibleOnly = False Then
If rtnNoTitle = False Then
Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol))
Set defineColRange = returnRange
Else
Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol))
Set defineColRange = returnRange
End If
Else
If rtnNoTitle = False Then
Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
Set defineColRange = returnRange
Else
Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
Set defineColRange = returnRange
End If
End If
If Err <> 0 Then
Debug.Print "Worksheet: " & targetWorkSheet.Name & " Column Name: " & targetValue
End If
On Error GoTo 0
Err.Clear
End If
End Function

Evaluate next value in array, if condition becomes false in macro

There are 3 values in array. Out of those, 1 value is not there in the column for which I'm filtering the data ("matang"). I want to know how should i make it skip if there is no result for that keyword. That means after filtering using that keyword, no results are displayed. I want to skip that keyword and move onto next element of array. I have tried On Error Resume Next. So any other option?
Dim Ar() As Variant
Ar() = Array("jumpsuit", "matang", "bikini")
Dim i As Variant
For Each i In Ar
Sheets("tops").Select
ActiveSheet.Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$1335").AutoFilter Field:=2, Criteria1:="*" & i & "*", Operator:=xlAnd
ActiveCell.Offset(0, 1).Range("A1").Select
Sheets("Sheet1").Select
Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Range("A1").Select
Selection.Copy
Selection.End(xlUp).Select
Sheets("tops").Select
Do
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell.EntireRow.Hidden = True
ActiveSheet.Paste

Try wrapping everything after your Autofilter in a test for no results:
If ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
ie:
Dim Ar() As Variant
Ar() = Array("jumpsuit", "matang", "bikini")
Dim i As Variant
For Each i In Ar
Sheets("tops").Select
ActiveSheet.Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$1335").AutoFilter Field:=2, Criteria1:="*" & i & "*", Operator:=xlAnd
If ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
ActiveCell.Offset(0, 1).Range("A1").Select
Sheets("Sheet1").Select
Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Range("A1").Select
Selection.Copy
Selection.End(xlUp).Select
Sheets("tops").Select
Do
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell.EntireRow.Hidden = True
ActiveSheet.Paste
End If
Next i

You could just add a CountIf bit of logic in there to test if the i'th element of the array exists in the range? And then jump past the section of code that makes changes if it doesnt exist (ie = 0)? In my example, i've used the term 'skip'. So like this....
Dim Ar() As Variant
Ar() = Array("jumpsuit", "matang", "bikini")
Dim i As Variant
For Each i In Ar
Sheets("tops").Select
ActiveSheet.Range("B1").Select
If Application.WorksheetFunction.CountIf(ActiveSheet.Range("$A$1:$D$1335"), i) = 0 Then
GoTo Skip
End If
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$1335").AutoFilter Field:=2, Criteria1:="*" & i & "*", Operator:=xlAnd
ActiveCell.Offset(0, 1).Range("A1").Select
Sheets("Sheet1").Select
Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Range("A1").Select
Selection.Copy
Selection.End(xlUp).Select
Sheets("tops").Select
Do
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell.EntireRow.Hidden = True
ActiveSheet.Paste
Then just put the 'skip:' term somewhere just before the next (I cant see it in your code, is it because this is just a section of a larger sub?)

Make a function that check a list with the wanted values after put them in a sheet.
Function checking(value as string)
Dim x as integer
Dim numWantedvalues as Integer
numWantedvalues = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet2").Range("A:A"))
For x = 1 to numWantedvalues
If ThisWorkbook.Sheets("Sheet2").Range("A" & x) = value Then
checking = True
End If
Next x
end function
Then introduce the function in your code:
If checking(arValue) = True Then
'Actions that you want to do
End If

Data Mining Macro Copy and Paste Values From multiple workbooks to a single workbook

This is what I have right now to work with. I am trying to alter this Macro to Find a specific value/text and copy that data to the Data mining workbook.
Currently this Macro copies specific cells. I basically want to change this to a find and copy function.
I think if I can figure out how to make it work for the "' Find and Copy date from Interval Summary.", then I can use that method to change all off the other parts of the Macro. That section has my current attempt make this macro work but I keep getting errors.
Public Sub CommandButton1_Click()
' Record job, modular code, multiple customers.
Dim counter As Integer
Dim PadPercentage As Single
Dim Charactercounter As Integer
Dim Date1 As String
Dim Date2 As String
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim Designcounter As Integer
Dim Customer As String
Dim Chemicals As String
Dim Chemcounter As Integer
Dim column As String
Dim Sand As Integer
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Designcounter = -1
With fd
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
Designcounter = Designcounter + 1
Workbooks.Open Filename:=vrtSelectedItem
Sheets("Interval Summary").Select
counter = 4
Charactercounter = 1
' Find and Copy date from Interval Summary.
With Worksheets("Interval Summary")
Set FindRow = Range("B:B").Find(What:="Date:", LookIn:=xlPart).Select
ActiveCell.Offset(0, 3).Select
Selection.Copy
End With
Windows("2014 GJ PE Engineering Job Logs - Iteration 1.xls").Activate
Range("A" & CStr(counter)).Select
' Search for first blank cell in column A.
Do While ActiveCell.Value <> ""
counter = counter + 1
Range("A" & CStr(counter)).PasteSpecial xlPasteValuesAndNumberFormats
Loop
' Paste date onto job recording sheet.
Range("A" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.UnMerge
Selection.NumberFormat = "m/d/yyyy"
' Record previous engineer name on job recording sheet.
Range("B" & CStr(counter - 1)).Select
Selection.Copy
Range("B" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy customer name onto reporting sheet.
ActiveWindow.ActivatePrevious
Worksheets("Actual Design").Range("C1").Select
Customer = ActiveCell.Value
Selection.Copy
ActiveWindow.ActivatePrevious
Range("E" & CStr(counter)).Select
ActiveSheet.Paste
' Paste SO from design onto recording sheet.
ActiveWindow.ActivateNext
If Customer = "Noble Energy Inc." Then
Worksheets("Design").Range("O1").Select
Else
Worksheets("Design").Range("Q1").Select
End If
Selection.Copy
ActiveWindow.ActivatePrevious
Range("C" & CStr(counter)).Select
ActiveSheet.Paste
Selection.UnMerge
Call Lease_Pad_Well_Copy(Customer, counter)
' Find and Copy Interval # from Well Data
With Worksheets("Well Data")
Set FindRow = .Range("B:B").Find(What:="Date", LookIn:=xlValues)
Windows("2014 GJ PE Engineering Job Logs.xls").Activate
Range("A" & CStr(counter)).Select
End With
' Copy mid perf depth to reporting sheet.
Worksheets("Actual").Range("C40").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("I" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy mid perf depth TVD to reporting sheet.
Worksheets("Actual").Range("C40").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("I" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy Top perf depth to reporting sheet.
Worksheets("Actual").Range("C40").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("I" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy Bottom perf depth to reporting sheet.
Worksheets("Actual").Range("C40").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("I" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy formation name to reporting sheet.
ActiveWindow.ActivateNext
Worksheets("Design").Range("C3").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("J" & CStr(counter)).Select
ActiveSheet.Paste
' Copy fluid system.
Range("K" & CStr(counter - 1)).Select
Selection.Copy
Range("K" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy crew from previous job.
Range("L" & CStr(counter - 1)).Select
Selection.Copy
Range("L" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Customer = "x3" Or Customer = "Chevron" Then
Call Copy_x3_Data(Customer, counter)
End If
If Customer = "x1." Then
Call Copyx1_Data(Customer, counter)
End If
If Customer = "x2" Then
Call Copy_x2(Customer, counter)
End If
' Copy slurry volume
If Customer = "Williams Prod RMT" Then
ActiveWindow.ActivateNext
Sheets("Actuals").Select
Worksheets("Actuals").Range("H30").Select
Selection.Copy
Else
ActiveWindow.ActivateNext
Sheets("Design").Select
Worksheets("Design").Range("H30").Select
Selection.Copy
End If
ActiveWindow.ActivatePrevious
Range("S" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy chemicals from design to Job recording sheet.
ActiveWindow.ActivateNext
Chemcounter = 78
column = Chr(Chemcounter)
Sheets("Well Data").Select
Worksheets("Design").Range(column & "5").Select
Do While ActiveCell.Value <> ""
If Chemcounter < 79 Then Chemicals = ActiveCell.Value
If Chemcounter > 78 Then Chemicals = Chemicals & ", " & ActiveCell.Value
Chemcounter = Chemcounter + 1
column = Chr(Chemcounter)
Worksheets("Well Data").Range(column & "5").Select
Loop
ActiveWindow.ActivatePrevious
Range("P" & CStr(counter)).Select
ActiveCell.Value = Chemicals
' Switch back to and close design
ActiveWindow.ActivateNext
ActiveWorkbook.Save
ActiveWindow.Close
Next vrtSelectedItem
End If
End With
' Format job log entries.
ActiveWindow.ActivatePrevious
Range("A" & CStr(counter - Designcounter) & ":AE" & CStr(counter)).Select
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = False
Rows(CStr(counter) & ":" & CStr(counter)).Select
Selection.RowHeight = 13.5
End Sub
Sub Lease_Pad_Well_Copy(Customer, counter)
Dim Wellstrng As String
Dim Pad As String
Dim Wellpad As String
Dim Lease As String
Dim Well As String
If Customer = "x5" Or Customer = "x6" Or Customer = "Noble Energy Inc." Or Customer = "x2" Then
' Sort lease, well, and pad number and copy to reporting sheet.
ActiveWindow.ActivateNext
Worksheets("Design").Range("C2").Select
If ActiveCell.Value <> "" Then
Wellstrng = ActiveCell.Value
Lease = Left(Wellstrng, CLng(InStr(Wellstrng, " ")) - 1)
Pad = Right(Wellstrng, Len(Wellstrng) - CLng(InStrRev(Wellstrng, "-")))
Wellpad = Left(Wellstrng, CLng(InStr(Wellstrng, "-")) - 1)
Well = Right(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, " ")))
If Customer = "Noble Energy Inc." Then
Wellstrng = ActiveCell.Value
Lease = Left(Wellstrng, CLng(InStr(Wellstrng, " ")) - 1)
Wellpad = Right(Wellstrng, Len(Wellstrng) - CLng(InStr(Wellstrng, " ")))
Wellpad = Left(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, " -")))
Pad = Left(Wellpad, CLng(InStr(Wellpad, "-")) - 1)
Wellpad = Left(Wellstrng, CLng(InStr(Wellstrng, " -")) - 1)
Well = Right(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, "-")))
End If
If Customer = "x2." Then
Wellstrng = ActiveCell.Value
Lease = Left(Wellstrng, CLng(InStr(Wellstrng, " ")) - 1)
Pad = Right(Wellstrng, Len(Wellstrng) - CLng(InStr(Wellstrng, "-")))
Wellpad = Left(Wellstrng, CLng(InStr(Wellstrng, "-")) - 1)
Well = Right(Wellpad, Len(Wellpad) - CLng(InStrRev(Wellpad, " ")))
End If
ActiveWindow.ActivatePrevious
' Copy lease name onto reporting sheet.
Range("F" & CStr(counter)).Select
ActiveCell.Value = Lease
' Copy well number onto reporting sheet.
Range("G" & CStr(counter)).Select
ActiveCell.Value = Well
' Copy pad onto reporting sheet.
Range("H" & CStr(counter)).Select
ActiveCell.Value = Pad
ActiveWindow.ActivateNext
End If
End If
End Sub
Sub Copy_BBC(Customer, counter)
Dim Twosands As String
Dim Sandint As Integer
' Copy average rate
ActiveWindow.ActivateNext
Sheets("Database").Select
Worksheets("Database").Range("B16").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("M" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy average pressure
ActiveWindow.ActivateNext
Worksheets("Database").Range("B17").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("N" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy perfs open.
ActiveWindow.ActivateNext
Worksheets("Database").Range("G18").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("W" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy actual sand
ActiveWindow.ActivateNext
Worksheets("Database").Range("B26").Select
Twosands = ActiveCell.Value
Twosands = Twosands & " / "
Worksheets("Database").Range("B28").Select
Twosands = Twosands & ActiveCell.Value
ActiveWindow.ActivatePrevious
Range("Q" & CStr(counter)).Select
ActiveCell.Value = Twosands
' Copy initial frac gradient
ActiveWindow.ActivateNext
Sheets("Database").Select
Worksheets("Database").Range("B21").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("V" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy final frac gradient
ActiveWindow.ActivateNext
Worksheets("Database").Range("B23").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("Y" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy ISIP
ActiveWindow.ActivateNext
Worksheets("Database").Range("B20").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("U" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy ISDP
ActiveWindow.ActivateNext
Worksheets("Database").Range("B22").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("X" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Sub Copy_Williams_Data(Customer, counter)
' Copy average rate to reporting sheet.
ActiveWindow.ActivateNext
Sheets("Actuals").Select
Worksheets("Actuals").Range("G63").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("M" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy average pressure to reporting sheet.
ActiveWindow.ActivateNext
Worksheets("Actuals").Range("F63").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("N" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy perfs open.
ActiveWindow.ActivateNext
Worksheets("Actuals").Range("D64").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("W" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy actual sand
ActiveWindow.ActivateNext
Worksheets("Actuals").Range("D65").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("Q" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy initial frac gradient
ActiveWindow.ActivateNext
Sheets("Actuals").Select
Worksheets("Design").Range("D61").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("V" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy final frac gradient
ActiveWindow.ActivateNext
Worksheets("Actuals").Range("D63").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("Y" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy ISIP
ActiveWindow.ActivateNext
Worksheets("Actuals").Range("D60").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("U" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy ISDP
ActiveWindow.ActivateNext
Worksheets("Actuals").Range("D62").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("X" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Sub Copy_x4_(Customer, counter)
Dim SandColor As String
Dim Sieve As String
Dim Sandtemp As String
Dim Sandtype As String
' Copy average rate to reporting sheet.
ActiveWindow.ActivateNext
Sheets("Actuals Design").Select
Worksheets("Actual Design").Range("H63").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("M" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy average pressure to reporting sheet.
ActiveWindow.ActivateNext
Worksheets("Actual Design").Range("H62").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("N" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy Total perfs open.
ActiveWindow.ActivateNext
Worksheets("Actual Design").Range("E65").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("W" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy actual sand.
ActiveWindow.ActivateNext
Worksheets("Design").Range("M61").Select
Greensand = ActiveCell.Value
Worksheets("Design").Range("M60").Select
Whitesand = ActiveCell.Value & " / "
Combinedsand = Whitesand & Greensand
ActiveWindow.ActivatePrevious
Range("Q" & CStr(counter)).Select
ActiveCell.Value = Combinedsand
' Copy initial frac gradient
ActiveWindow.ActivateNext
Sheets("Interval Summart").Select
Worksheets("Design").Range("E64").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("V" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy final frac gradient
ActiveWindow.ActivateNext
Worksheets("Design").Range("H65").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("Y" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy ISIP
ActiveWindow.ActivateNext
Worksheets("Design").Range("E63").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("U" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Copy ISDP
ActiveWindow.ActivateNext
Worksheets("Design").Range("H64").Select
Selection.Copy
ActiveWindow.ActivatePrevious
Range("X" & CStr(counter)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

With the .Find method, you need to set the range before you can .Select it.
In the section you're talking about, you should change
Set FindRow = Range("B:B").Find(What:="Date:", LookIn:=xlPart).Select
to this:
Set FindRow = Range("B:B").Find(What:="Date:", LookAt:=xlPart)
FindRow.Select

Resources