Run-time error 91 on arrays - vba

I'm getting Run-time error 91 on several variable, and I really have no idea what I'm doing wrong...
The variables are: IQRngRef, tempRng, unionVariable
I assume it has something with them all being arrays with the exception of unionVariable (at least it shouldn't be).
Could I get some help here please?
Option Explicit
Private Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
' 4. Copy table from xl Paste Table into ppt
' 5. Do this for every slide
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ShRef As Excel.Worksheet
Dim pptPres As Object
Dim colNumb As Long
Dim rowNumb As Long
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\Pinlop\Desktop\Gate\Macros\averageScores\pptxlpratice\dummy2.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlApp.DisplayAlerts = False
'Find # of iq's in workbook
Set ShRef = xlWB.Worksheets("Sheet1")
colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row
Dim IQRef() As String
Dim iCol As Long
Dim IQRngRef() As Range
ReDim IQRef(colNumb)
ReDim IQRngRef(colNumb)
' capture IQ refs locally
For iCol = 2 To colNumb
IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)).Value
IQRef(iCol) = ShRef.Cells(1, iCol).Value
Next iCol
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Create variables for the slide loop
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim iq_Array As Variant
Dim arrayLoop As Long
Dim myShape As Object
Dim outCol As Long
Dim i As Long
Dim lRows As Long
Dim lCols As Long
Dim k As Long
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
i = 0
pptSlide.Select
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
If Not Shpe.HasTextFrame Then GoTo nextShpe 'boom, one less nested If statement
If Not Shpe.TextFrame.HasText Then GoTo nextShpe ' boom, another nested If statement bites the dust
outCol = 0
'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
pptText = Shpe.TextFrame.TextRange
pptText = LCase(Replace(pptText, " ", vbNullString))
pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
'Identify if within text there is "iq_"
If InStr(1, pptText, "iq_") <= 0 Then GoTo nextShpe
'set iq_Array as an array of the split iq's
iq_Array = Split(pptText, ",")
Dim hasIQs As Boolean
Dim checkStr As String
Dim pCol As Long
Dim checkOne
checkOne = iq_Array(0)
hasIQs = Left(checkOne, 3) = "iq_"
Dim tempRng() As Range
If hasIQs Then
' paste inital column into temporary worksheet
tempRng(0) = ShRef.Columns(1)
End If
' loop for each iq_ in the array
For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
' Take copy of potential ref and adjust to standard if required
checkStr = iq_Array(arrayLoop)
If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr
' Look for existence of corresponding column in local copy array
pCol = 0
For iCol = 2 To colNumb
If checkStr = IQRef(iCol) Then
pCol = iCol
Exit For
End If
Next iCol
If pCol > 0 Then
' Paste the corresponding column into the forming table
outCol = outCol + 1
tempRng(outCol) = ShRef.Columns(pCol)
End If
Next arrayLoop
If outCol > 1 Then 'data was added
' Copy table
Dim unionVariable As Range
unionVariable = tempRng(0)
For k = 1 To i
unionVariable = Union(unionVariable, tempRng(k))
Next k
unionVariable.Copy ' all the data added to ShWork
tryAgain:
ActiveWindow.ViewType = ppViewNormal
ActiveWindow.Panes(2).Activate
Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
On Error GoTo tryAgain
On Error GoTo clrSht
'Set position:
myShape.Left = -200
myShape.Top = 150 + i
i = i + 150
End If
clrSht:
'Clear Sheet2 for next slide
Erase tempRng()
nextShpe:
Next Shpe
nextSlide:
Next pptSlide
xlWB.Close
xlApp.Quit
xlApp.DisplayAlerts = True
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

Dim something() As String
That's declaring a dynamically-sized array, where each item is a String. Once it's resized, you can do this (assuming i is within the boundaries of the array):
something(i) = "foo"
Now this:
Dim something() As Range
That's declaring a dynamically-sized array, where each item is a Range. Once it's resized, you can do this (assuming i is within the boundaries of the array):
Set something(i) = Range("A1")
Notice the Set keyword - it's required in VBA, whenever you're assigning an object reference. Range being an object, you need the Set keyword for that assignment.
In your code:
tempRng(0) = ShRef.Columns(1)
That's indeed a Range, but the Set keyword is missing. That will throw the RTE91 you're getting.
Same here:
unionVariable = tempRng(0)
You can't assign an object reference without the Set keyword.
Here though:
IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)).Value
That's not a Range. It's the .Value of a Range, and that's a Variant - not an object, so adding the Set keyword isn't going to fix anything. If you mean IQRngRef to hold Range objects, you need to do this:
Set IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol))

Related

VBA- Import Multiple CSV to a Sheet, Remove Certain Rows/Columns

I am completely new to VBA, but I have CSV files(same format for all of them), and I want to import them to a single sheet on Excel. I was able to read the CSV file according to this code:
Sub R_AnalysisMerger()
Dim WSA As Worksheet
Dim bookList As Workbook
Dim SelectedFiles() As Variant
Dim NFile As Long
Dim FileName As String
Dim ws As Worksheet, vDB As Variant, rngT As Range
Application.ScreenUpdating = False
'Selects the CSV files as SELECTED FILES
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.Clear 'Clears current worksheet
SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True) 'Selects csv files
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
Set bookList = Workbooks.Open(FileName, Format:=2)
Set WSA = bookList.Sheets(1)
With WSA
vDB = .UsedRange
Set rngT = ws.Range("a" & Rows.count).End(xlUp)(2)
If rngT.Row = 2 Then Set rngT = ws.Range("A1")
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
bookList.Close (0)
End With
Next
Application.ScreenUpdating = True
ws.Range("A1").Select
But I have additional requirements:
Skip the first column.
Skip the first four rows.
Remove a certain String from each word in the fifth row.
Im used to java, and usually I would read each line with a "for" loop and set "if" statements to skip the first row and four columns and remove the string from each string if it was present.
I don't know how to do this with this code. From what I understand it just copies the whole CSV file into the sheet?
This solution is based on reading CSV as textstream. I have tried to include feature that makes possible most all things like selecting columns, Rows and so on.
Sub ImportCSV()
Dim fso As New IWshRuntimeLibrary.FileSystemObject
Dim txtStream As IWshRuntimeLibrary.TextStream
Dim files As IWshRuntimeLibrary.files
Dim file As IWshRuntimeLibrary.file
Dim txtLine As String
Dim lineCount As Integer
Dim lastRow As Integer
Dim lineCol As Variant
Dim rng As Range
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).usedRange.Delete
Set rng = ThisWorkbook.Sheets(1).usedRange
lastRow = 1
Set files = fso.GetFolder("path\folder").files
For Each file In files
If file.Name Like "*.csv" Then
Set txtStream = file.OpenAsTextStream(ForReading, TristateUseDefault)
txtStream.SkipLine ' skip first line, since it containes headers
lineCount = 1
Do
txtLine = txtStream.ReadLine
If lineCount = 5 Then
txtLine = Replace(txtLine, "stringToReplace", "StringToReplcaeWith") ' replace certain string from words in 5'th row
End If
lineCount = lineCount + 1
lineCol = sliceStr(Split(txtLine, ";"), startIdx:=4) ' slice the array so to skip four first columns
For iCol = 0 To UBound(lineCol) ' write columns to last row
rng(lastRow, iCol + 1).Value = lineCol(iCol)
Next iCol
lastRow = lastRow + 1
'Debug.Print Join(lineCol, ";") ' debug
Loop Until txtStream.AtEndOfStream
End If
Next file
Application.ScreenUpdating = True
End Sub
This is the slicer function
Function sliceStr(arr As Variant, startIdx As Integer, Optional stopIdx As Integer = 0) As String()
If stopIdx = 0 Then
stopIdx = UBound(arr)
End If
Dim tempArrStr() As String
ReDim tempArrStr(stopIdx - startIdx)
Dim counter As Integer
counter = 0
For i = startIdx To stopIdx
tempArrStr(counter) = arr(i)
counter = counter + 1
Next
sliceStr = tempArrStr
End Function
I just did a simple test and the code below seems to work. Give it a go, and feedback.
Sub Demo()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Application.ScreenUpdating = False
Dim newWS As Worksheet
Set newWS = Sheets.Add(before:=Sheets(1))
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder("C:\Users\ryans\OneDrive\Desktop\output\") ' <-- use your FileDialog code here
Mask = "*.csv"
'Debug.Print fldStart.Path & ""
ListFiles fldStart, Mask
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
ListFolders fld, Mask
Next
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim L As Long, t As Long, i As Long
L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
t = 1
For i = 1 To L
Workbooks.OpenText Filename:=myWB.Sheets(1).Cells(i, 1).Value, DataType:=xlDelimited, Tab:=True
Set WB = ActiveWorkbook
lrow = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
WB.Sheets(1).Range("B4:E" & lrow).Copy newWS.Cells(t, 2)
t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
WB.Close False
Next
myWB.Sheets(1).Columns(1).Delete
Application.ScreenUpdating = True
End Sub
Sub ListFolders(fldStart As Object, Mask As String)
Dim fld As Object 'Folder
For Each fld In fldStart.SubFolders
'Debug.Print fld.Path & ""
ListFiles fld, Mask
ListFolders fld, Mask
Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim t As Long
Dim fl As Object 'File
For Each fl In fld.Files
If fl.Name Like Mask Then
t = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
'Debug.Print fld.Path & "" & fl.Name
If Sheets(1).Cells(1, 1) = "" Then
Sheets(1).Cells(1, 1) = fld.Path & "\" & fl.Name
Else
Sheets(1).Cells(t, 1) = fld.Path & "\" & fl.Name
End If
End If
Next
End Sub

Unique list from a matrix to a single column

I needed to collect a unique list of text from a matrix, ("J19:BU500" in my case which contains duplicates) and paste it in a column (column DZ in my case) in the same sheet.
I need to loop this for multiple sheets in the same workbook. I'm new to VBA and got this code from internet and customized a bit to my requirement. But I have two problems with the code:
When the matrix is empty in say sheet 5, the code runs fine upto sheet 4 and throws a runtime error at sheet5 and stops without looping further to next sheets.
Also, I actually wanted the unique list to start at Cell "DZ10". If I do that, the number of unique list reduces by 10. For say there are 25 uniques, only 15 gets pasted starting from cell "DZ10" whereas all 25 gets pasted from cell "DZ1".
Code:
Public Function CollectUniques(rng As Range) As Collection
Dim varArray As Variant, var As Variant
Dim col As Collection
If rng Is Nothing Or WorksheetFunction.CountA(rng) = 0 Then
Set CollectUniques = col
Exit Function
End If
If rng.Count = 1 Then
Set col = New Collection
col.Add Item:=CStr(rng.Value), Key:=CStr(rng.Value)
Else
varArray = rng.Value
Set col = New Collection
On Error Resume Next
For Each var In varArray
If CStr(var) <> vbNullString Then
col.Add Item:=CStr(var), Key:=CStr(var)
End If
Next var
On Error GoTo 0
End If
Set CollectUniques = col
End Function
Public Sub WriteUniquesToNewSheet()
Dim wksUniques As Worksheet
Dim rngUniques As Range, rngTarget As Range
Dim strPrompt As String
Dim varUniques As Variant
Dim lngIdx As Long
Dim colUniques As Collection
Dim WS_Count As Integer
Dim I As Integer
Set colUniques = New Collection
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 3 To WS_Count
Sheets(I).Activate
Set rngTarget = Range("J19:BU500")
On Error GoTo 0
If rngTarget Is Nothing Then Exit Sub '<~ in case the user clicks Cancel
Set colUniques = CollectUniques(rngTarget)
ReDim varUniques(colUniques.Count, 1)
For lngIdx = 1 To colUniques.Count
varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx))
Next lngIdx
Set rngUniques = Range("DZ1:DZ" & colUniques.Count)
rngUniques = varUniques
Next I
MsgBox "Finished!"
End Sub
Any help is highly appreciated. Thankyou
You need to select the correct amount of cells to fill in all data from an array. Like Range("DZ10").Resize(RowSize:=colUniques.Count)
That error probably means that colUniques is nothing and therefore has no .Count. So test if it is Nothing before you use it.
You will end up with something like below:
Public Sub WriteUniquesToNewSheet()
Dim wksUniques As Worksheet
Dim rngUniques As Range, rngTarget As Range
Dim strPrompt As String
Dim varUniques As Variant
Dim lngIdx As Long
Dim colUniques As Collection
Dim WS_Count As Integer
Dim I As Integer
Set colUniques = New Collection
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 3 To WS_Count
Sheets(I).Activate
Set rngTarget = Range("J19:BU500")
'On Error GoTo 0 'this is pretty useless without On Error Resume Next
If rngTarget Is Nothing Then Exit Sub 'this is never nothing if you hardcode the range 2 lines above (therefore this test is useless)
Set colUniques = CollectUniques(rngTarget)
If Not colUniques Is Nothing Then
ReDim varUniques(colUniques.Count, 1)
For lngIdx = 1 To colUniques.Count
varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx))
Next lngIdx
Set rngUniques = Range("DZ10").Resize(RowSize:=colUniques.Count)
rngUniques = varUniques
End If
Next I
MsgBox "Finished!"
End Sub

Using Cells inside of Range isn't working? [duplicate]

This question already has answers here:
Excel VBA, getting range from an inactive sheet
(3 answers)
Closed 5 years ago.
For some reason this isn't working:
.Range(Cells(1, 1), Cells(lRows, lCols)).Copy
Any ideas? It's on line 78
Option Explicit
Public Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56, iq_72".
' 3. find those words and numbers in the opened Excel file. Needs to recognize that ", " means there is another entry.
' 3. Copy column containing words from ppt ie. "iq_43"
' 4. Paste a Table into ppt with those values
' 5. Do this for every slide
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim pptPres As Object
Dim iq_Array As Variant
Dim arrayLoop As Integer
Dim i As Integer
Dim myShape As Object
Dim colNumb As Integer
Dim size As Integer
Dim k As Integer
Dim vsblSld As Object
Dim lRows As Long
Dim lCols As Long
colNumb = 5 'Set #of columns in the workbook
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\pinlop\Desktop\Gate\Macro\averageScores\pptxlpratice\dummyavgscore.xlsx", True, False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlWB.Worksheets.Add After:=xlWB.ActiveSheet
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
'Identify if there is text frame
k = 1
If Shpe.HasTextFrame Then
'Identify if there's text in text frame
If Shpe.TextFrame.HasText Then
pptText = Shpe.TextFrame.TextRange
If InStr(1, pptText, "iq_") > 0 Then 'Identify if within text there is "iq_" All IQ's have to be formatted like this "iq_42, iq_43" for now
iq_Array = Split(pptText, ", ") 'set iq_Array as an array of the split iq's
size = UBound(iq_Array) - LBound(iq_Array)
For arrayLoop = 0 To size 'loop for each iq_array
For i = 1 To colNumb 'loops for checking each column
If i = 1 And arrayLoop = 0 Then 'Copies the first column for every slide
xlWB.Worksheets("Sheet1").Columns(1).Copy 'copy column
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1)
ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = iq_Array(arrayLoop) And i <> 1 Then 'if iq in ppt = iq in xl and if not the first cell then execute
k = k + 1
xlWB.Worksheets("Sheet1").Columns(i).Copy
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k)
End If
Next i
Next arrayLoop
End If
End If
End If
Next Shpe
'calculate last row and last column
With xlWB.Worksheets("Sheet2")
lRows = .Cells(.Rows.Count, 1).End(xlUp).Row
lCols = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(Cells(1, 1), Cells(lRows, lCols)).Copy
End With
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse
Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 152
xlWB.Worksheets("Sheet2").Range("A1:P10").Clear
Next pptSlide
xlWB.Worksheets("Sheet2").Delete
End Sub
It should be like this:
.Range(.Cells(1, 1), .Cells(lRows, lCols)).Copy
That's one of the errors everyone experiences with VBA, if he goes a bit deeper. The reason is that Cells and Range should both be referred to the worksheet, otherwise they would refer the ActiveSheet.
And in general, consider using Long instead of Integer in your code.

Copy Worksheets break links

I have the below 2 subs in VBA which perform 2 different but similar tasks. One allows you to selects sheets from a Workbook using a checkbox popup and then copies these sheets into a new blank Workbook. The other allows you to manually populate a list of names of the sheets you want to copy (i.e. setup a "batch" of sorts) on a sheet and then copy all the sheets across into a new blank Workbook in a similar fashion to the first.
The problem I am having is - with the first sub I am able to break links after copying into the new Workbook, but with the second sub I am not able to break links. I think it has to do with a number of defined names within the original Workbook, as if you "Move or Copy/Create a Copy" manually, you are able to break the links.
Is there any code I can add to the below (onto both subs if possible) which will automatically break all links in the new Workbook to the old one? Or at least, is it possible to amend the second sub so that it copies across in a similar fashion to the first one which will then allow me to break links manually?
Sub CopySelectedSheets()
'1. Declare variables
Dim I As Integer
Dim SheetCount As Integer
Dim TopPos As Integer
Dim lngCheckBoxes As Long, y As Long
Dim intTopPos As Integer, intSheetCount As Integer
Dim intHor As Integer
Dim intWidth As Integer
Dim intLBLeft As Integer, intLBTop As Integer, intLBHeight As Integer
Dim Printdlg As DialogSheet
Dim CurrentSheet As Worksheet, wsStartSheet As Worksheet
Dim CB As CheckBox
Dim firstSelected As Boolean
' Dim wb As Workbook
' Dim wbNew As Workbook
' Set wb = ThisWorkbook
' Workbooks.Add ' Open a new workbook
' Set wbNew = ActiveWorkbook
On Error Resume Next
Application.ScreenUpdating = False
'2. Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
'3. Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set wsStartSheet = ActiveSheet
Set Printdlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
'4. Add the checkboxes
TopPos = 40
For I = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(I)
'Skip empty sheets and hidden sheets
If Application.CountA(CurrentSheet.Cells) <> 0 And _
CurrentSheet.Visible Then
SheetCount = SheetCount + 1
Printdlg.CheckBoxes.Add 78, TopPos, 150, 16.5
Printdlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
TopPos = TopPos + 13
End If
Next I
'6. Move the OK and Cancel buttons
Printdlg.Buttons.Left = 240
'7. Set dialog height, width, and caption
With Printdlg.DialogFrame
.Height = Application.Max _
(68, Printdlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to generate"
End With
'Change tab order of OK and Cancel buttons
'so the 1st option button will have the focus
Printdlg.Buttons("Button 2").BringToFront
Printdlg.Buttons("Button 3").BringToFront
'9. Display the dialog box
CurrentSheet.Activate
wsStartSheet.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
If Printdlg.Show Then
For Each CB In Printdlg.CheckBoxes
If CB.Value = xlOn Then
If firstSelected Then
Worksheets(CB.Caption).Select Replace:=False
Else
Worksheets(CB.Caption).Select
firstSelected = True
End If
'For y = 1 To ActiveWorkbook.Worksheets.Count
'If WorksheetFunction.IsNumber _
'(InStr(1, "ActiveWorkbook.Sheets(y)", "Contents")) = True Then
'CB.y = xlOn
'End If
End If
Next
ActiveWindow.SelectedSheets.Copy
Else
MsgBox "No worksheets selected"
End If
End If
' Delete temporary dialog sheet (without a warning)
'' Application.DisplayAlerts = False
'' Printdlg.Delete
' Reactivate original sheet
'' CurrentSheet.Activate
'' wsStartSheet.Activate
'10.Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
Printdlg.Delete
'11.Reactivate original sheet
CurrentSheet.Activate
wsStartSheet.Activate
Application.DisplayAlerts = True
End Sub
Sub CopySpecificSheets()
'1. Declare Variables
Dim myArray() As String
Dim myRange As Range
Dim Cell As Range
Dim OldBook As String
Dim newBook As String
Dim a As Long
'2. Set Range of Lookup
Set myRange = Sheets("Report Batch").Range("A2:A40")
OldBook = ActiveWorkbook.Name
'3. Generate Array of Sheet Names removing Blanks
For Each Cell In myRange
If Not Cell = "" Then
a = a + 1
ReDim Preserve myArray(1 To a)
myArray(a) = Cell
End If
Next
'4. Copy Array of Sheets to new Workbook
For a = 1 To UBound(myArray)
If a = 1 Then
Sheets(myArray(a)).Copy
newBook = ActiveWorkbook.Name
Workbooks(OldBook).Activate
Else
Sheets(myArray(a)).Copy After:=Workbooks(newBook).Sheets(a - 1)
Workbooks(OldBook).Activate
End If
Next
End Sub
Try something like this:
Sub CopySpecificSheets()
'1. Declare Variables
Dim rngData As Range
Dim arrData As Variant
Dim arrSheets() As String
Dim lSheetCount As Long
Dim i As Long
Dim j As Long
'2. Initialize variables
Set rngData = Sheets("Report Batch").Range("A2:A40")
arrData = rngData.Value
lSheetCount = WorksheetFunction.CountA(rngData)
ReDim arrSheets(lSheetCount - 1)
'3. Fill the array with non blank sheet names
For i = LBound(arrData) To UBound(arrData)
If arrData(i, 1) <> vbNullString Then
arrSheets(j) = arrData(i, 1)
j = j + 1
End If
' early break if we have all the sheets
If j = lSheetCount Then
Exit For
End If
Next i
'4. Copy the sheets in one step
Sheets(arrSheets).Copy
End Sub
Thanks
This isn't tested, but I think if you add in a subroutine to your source workbook VBA code like this:
Sub BreakLinks(ByRef wb As Workbook)
Dim Links As Variant
Dim i As Long
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
And then call it after you copy the sheets to the new workbook
Call BreakLinks(newBook)
That should achieve the desired effect of severing those links. Just be sure the links are broken to any sort of Save or SaveAs operation so that the broken links are maintained.

Column headers to new sheet

I am trying to use a file picker, which I have and then get the columns of every file and every sheet within that file into a new sheet. So A1 would have file name,B1 sheet name, C1 and down would have column headers (which are A1:?? in all the files Im picking).
Also some files are large so would having automatic calculation to automatic be helpful?
Also note that I have extra variables in the beggining but not necessarily used.
Here is the code, its a mess:
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As Range, intRow As Long, i As Integer
Dim r As Range, lr As Long, myrg As Range, z As Range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
'Skipped worksheet for file names
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Headers")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "headers"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
.Range("A1:C1").Value = Array("File Name", "Sheet Name", "headers")
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
' more working with wb
Code should go in here
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Autofit column widths of the report
wksSummary.Range("A1:C1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
I have the picker(a separate function) , I a skipped worksheet incase the file is corrupt, but I obviously am missing the part where to get the headers and sheet names.
Can anyone help?
UPDATE WITH MATTHEW'S CODE~~~~~~~~~~~~~~~~~~~~
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As range, intRow As Long, i As Integer
Dim r As range, lr As Long, myrg As range, z As range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
'need addition
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
'Skipped worksheet for file names
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Headers")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "headers"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
.range("A1:C1").Value = Array("File Name", "Sheet Name", "headers")
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
' more working with wb
'New addition
Dim iIndex As Integer
Dim lCol As Long
Dim lRow As Long
lRow = 1
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.Count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.range("A" & lRow).Value = wb.Name
wsReport.range("B" & lRow).Value = ws.Name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the header
wsReport.range(Col_Letter(lOutputCol) & lRow).Value = ws.range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
lCol = lCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Autofit column widths of the report
wksSummary.range("A1:C1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
TWO FUNCTIONS:
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
and
Function FileDialogDictionary(ByRef file As Object) As Boolean ' returns true if the user cancels
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Dim item As Variant
Dim i As Long
'Create a FileDialog object as a File Picker dialog box.
file.RemoveAll 'clear the dictionary
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
'of each selected item. Even though the path is a String,
'the variable must be a Variant because For Each...Next
'routines only work with Variants and Objects.
'Use a With...End With block to reference the FileDialog object.
With fd
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
.Title = "Select Excel Workbooks" 'Change this to suit your purpose
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Microsoft Excel files", "*.xlsx,*.xls"
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each item In .SelectedItems 'loop through all selected and add to dictionary
i = i + 1
file.Add i, item
Next item
FileDialogDictionary = False
'The user pressed Cancel.
Else
FileDialogDictionary = True
Set fd = Nothing
Exit Function
End If
End With
Set fd = Nothing 'Set the object variable to Nothing.
End Function
When you open a workbook it becomes active so you'll need to create an object that will be the sheet that you are writing to. Somewhere at the top.
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
Code to write out the data. Insert where you put "Code should go in here"
Dim iIndex As Integer
Dim lCol As Long
Dim lRow As Long
Dim lOutputCol As Long
lRow = 1
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.name
wsReport.Range("B" & lRow).Value = ws.name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.count
'Write the header
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
And you'll need to add this function
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function