I created a macro to import multiple spreadsheet into on master report. I tested it with some small files without any issues. But when I am trying to import a file with more then just a couple of rows, excel keeps freezing.
Sub openFile(ByRef file As String)
Dim wbMaster As Workbook: Set wbMaster = ThisWorkbook
Dim wsMaster As Worksheet: Set wsMaster = wbMaster.Sheets("Report")
Dim tbMaster As ListObject: Set tbMaster = wsMaster.ListObjects("Report")
Dim hdrMaster As ListColumn
Dim rowMaster As ListRow
Dim wbSlave As Workbook: Set wbSlave = Workbooks.Open(Application.ActiveWorkbook.path & "\" & file)
Dim wsSlave As Worksheet
Dim rowSlave As Range
Dim cellSlave As Range
Dim hdrSlave() As Variant
For Each wsSlave In wbSlave.Worksheets
For Each rowSlave In wsSlave.Rows
If rowSlave.Row <= 1 Then
For Each cellSlave In rowSlave.Cells
If Not IsEmpty(cellSlave) Then
Set hdrMaster = Nothing
On Error Resume Next
Set hdrMaster = tbMaster.ListColumns(cellSlave.Text)
On Error GoTo 0
If hdrMaster Is Nothing Then
Set hdrMaster = tbMaster.ListColumns.Add
hdrMaster.Name = cellSlave.Text
End If
ReDim Preserve hdrSlave(cellSlave.Column)
hdrSlave(cellSlave.Column) = cellSlave.Text
Else
Exit For
End If
Next cellSlave
Else
If Not IsEmpty(rowSlave.Cells(1)) Then
Set rowMaster = tbMaster.ListRows.Add
rowMaster.Range(tbMaster.ListColumns("File").Index) = file
For Each cellSlave In rowSlave.Cells
If Not IsEmpty(cellSlave) Then
rowMaster.Range(tbMaster.ListColumns(hdrSlave(cellSlave.Column)).Index) = cellSlave.Text
Else
Exit For
End If
Next cellSlave
Else
Exit For
End If
End If
Next rowSlave
Next wsSlave
tbMaster.Range.Columns.AutoFit
wbMaster.Save
wbSlave.Close (False)
End Sub
I am also turning off ScreenUpdating before calling the sub.
Here's what I mean.
I've pulled out the process of appending a range onto a Table/Listobject into AddRangeintoTable - you would call that from your main code.
I have a stub method Tester as an example of how it would be called.
Note the comment at the bottom of the main code about whether or not you'll need to resize the table after adding the new content - there's a setting in Options to control that.
Sub Tester()
AddRangeIntoTable Range("A4").CurrentRegion, _
ActiveSheet.ListObjects("Table2"), _
True
End Sub
'append a Range onto a Table/Listobject, optionally inserting
' any columns not found in the Table
Sub AddRangeIntoTable(FromRange As Range, ToTable As ListObject, _
Optional AppendNewCols As Boolean = False)
Dim c As Range, lc As ListColumn, data, rw, col, newData(), hdr
Dim dictColPos, rngHdrs As Range, i As Long, numRows As Long, numCols As Long
data = FromRange.Value 'get all new data as array
Set dictColPos = CreateObject("scripting.dictionary") 'for mapping columns
'map headers and (optionally) add any necessary headers not already present
For col = 1 To UBound(data, 2)
hdr = data(1, col)
Set lc = Nothing
On Error Resume Next
Set lc = ToTable.ListColumns(hdr)
On Error GoTo 0
If lc Is Nothing And AppendNewCols Then 'add mising column(s)?
Set lc = ToTable.ListColumns.Add
lc.Name = hdr
End If
If Not lc Is Nothing Then
dictColPos(hdr) = lc.Index 'map header name to column index position
End If
Next col
'size array for data to append to listobject and fill it
numRows = UBound(data, 1) - 1
numCols = ToTable.ListColumns.Count
ReDim newData(1 To numRows, 1 To numCols)
For rw = 2 To UBound(data, 1)
For col = 1 To UBound(data, 2)
If dictColPos.exists(data(1, col)) Then
newData(rw - 1, dictColPos(data(1, col))) = data(rw, col)
End If
Next col
Next rw
With ToTable
With .DataBodyRange
.Rows(.Rows.Count).Cells(1).Offset(1, 0) _
.Resize(numRows, numCols).Value = newData 'add the new data
End With
' Excel options >> Proofing >> Autocorrect options >> Autoformat as you type
' >> "Include new rows and columns in table"
If Not Application.AutoCorrect.AutoExpandListRange Then
.Resize ToTable.Range.Resize(.Range.Rows.Count + numRows)
End If
.Range.Columns.AutoFit
End With
End Sub
Related
I am working with an excel which has about 500000 rows.
I have one sheet called "B" where is all the info and I only need the rows where the column Y contains text, not de #N/A from the LOOKUP.
I have to copy the rows with info, to another sheet called "A".
I used this code for the same process
On Error Resume Next
Columns("Y").SpecialCells(xlFormulas, xlErrors).EntireRow.Delete
On Error GoTo 0
But in this case, there are many rows so it takes 5 minutes(not worthy)
I only have 3000 rows with non NA, so I thought it will be easier to filter them and copy to "A" the entire row(the column A from the row in "B" it's not necessary, and the destination sheet "A" the column A has to be empty).
I don't know how to do it, i'm new in this language, thank you
Sheet B; the column Y with the header SKU contains the not found and the found ones ex:SKU1233444
Sheet A;
I have to copy from B except headers and column A, all the rows with SKU found and paste them into Sheet A leaving its headers and the column A empty because it's formulated
Arrays work faster than deleting rows one by one in VBA
Arrays need to be transposed / flipped before they're pasted into a worksheet
I ran the code below and it works.
I assumed that we're only working from column B as your attached photo above seems to suggest
Option Explicit ensures that we declare all variables we use.
$ is short hand for string; % for integer; & for long
Option Explicit
Private Sub Test()
Dim sChar$, sRange$, sRange2$
Dim iCol%, iLastUsedCol%
Dim iLastUsedRow&, iRow&
Dim r As Range
Dim aCleaned As Variant, aData As Variant
Dim WS As Worksheet, WS2 As Worksheet
Set WS = ThisWorkbook.Sheets("A")
Set WS2 = ThisWorkbook.Sheets("B")
With WS
'furthest column to right on a worksheet
sChar = ColumnChars2(Columns.Count)
'last used header column on this sheet
iLastUsedCol = .Range(sChar & 1).End(xlToLeft).Column
'last used row of data on this sheet
iLastUsedRow = .Range("A" & Rows.Count - 1).End(xlUp).Row
'cells containing data
sRange = "B2:" & ColumnChars2(iLastUsedCol) & iLastUsedRow
'transferring data to array
aData = .Range(sRange)
End With
'temporary store for row of data
ReDim aParam(iLastUsedCol - 2)
'cleaned data
ReDim aCleaned(iLastUsedCol - 2, 0)
'setting first entry of cleaned data to blank initially - needed for AddEntry subroutine called below
aCleaned(0, 0) = ""
For iRow = 1 To UBound(aData)
'if Y column cell for this row does not contain error
If Not IsError(aData(iRow, 24)) Then
'save entire row temporarily
For iCol = 0 To UBound(aParam)
aParam(iCol) = aData(iRow, iCol + 1)
Next
'transfer saved row to cleaned data array
Call AddEntry(aCleaned, aParam)
End If
Next
With WS2
iLastUsedCol = .Range(sChar & 1).End(xlToLeft).Column
iLastUsedRow = .Range("B" & Rows.Count - 1).End(xlUp).Row
'if data in B sheet
If iLastUsedRow > 1 Then
sRange2 = "B2:" & ColumnChars2(iLastUsedCol) & iLastUsedRow
'empty
.Range(sRange2).ClearContents
End If
Set r = .Range("B2")
'copy cleaned data to sheet B
r.Resize(UBound(aCleaned, 2) + 1, UBound(aCleaned, 1) + 1).Value = my_2D_Transpose(aCleaned)
End With
End Sub
The first subroutine called by the test routine above:
Public Function ColumnChars2(iCol As Variant) As String
On Error GoTo Err_Handler
'
' calculates character form of column number
'
Dim iPrePrefix As Integer, iPrefix As Integer, iSuffix As Integer
iSuffix = iCol
iPrefix = 0
Do Until iSuffix < 27
iSuffix = iSuffix - 26
iPrefix = iPrefix + 1
Loop
iPrePrefix = 0
Do Until iPrefix < 27
iPrefix = iPrefix - 26
iPrePrefix = iPrePrefix + 1
Loop
ColumnChars2 = IIf(iPrePrefix = 0, "", Chr(64 + iPrePrefix)) & IIf(iPrefix = 0, "", Chr(64 + iPrefix)) & Chr(64 + iSuffix)
Exit Function
Exit_Label:
On Error Resume Next
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Exit Function
Err_Handler:
MsgBox Err.Description, vbCritical, "ColumnChars2"
Resume Exit_Label
End Function
The second subroutine called by the test routine above:
Public Sub AddEntry(aList As Variant, aEntry As Variant)
'
' build array for later copy onto sheet
'
Dim i%
Dim aEntry2 As Variant
If VarType(aEntry) = vbString Then
aEntry2 = Array(aEntry)
Else
aEntry2 = aEntry
End If
If aList(0, 0) <> "" Then
ReDim Preserve aList(0 To UBound(aEntry2), 0 To UBound(aList, 2) + 1)
End If
For i = 0 To UBound(aEntry2)
aList(i, UBound(aList, 2)) = aEntry2(i)
Next
End Sub
The third subroutine called by the test routine above:
Function my_2D_Transpose(arr As Variant)
On Error GoTo Err_Handler
'works better than delivered Application.Transpose function
Dim a&, b&, tmp As Variant
ReDim tmp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For a = LBound(arr, 1) To UBound(arr, 1)
For b = LBound(arr, 2) To UBound(arr, 2)
tmp(b, a) = arr(a, b)
Next b
Next a
my_2D_Transpose = tmp
Exit Function
Exit_Label:
On Error Resume Next
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Exit Function
Err_Handler:
MsgBox Err.Description, vbCritical, "my_2D_Transpose"
Resume Exit_Label
End Function
Copy Criteria Rows
Option Explicit
Sub CopyNoErrors()
' Define constants.
' Source
Const sName As String = "B"
Const CritColumnString As String = "Y"
' Destination
Const dName As String = "A"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim rCount As Long
Dim cCount As Long
' Reference the source range ('srg') excluding the first column
' and the headers.
With sws.Range("A1").CurrentRegion
rCount = .Rows.Count - 1
cCount = .Columns.Count - 1
Set srg = .Resize(rCount, cCount).Offset(1, 1)
End With
' Determine the criteria column ('CritColumn') which has to be reduced
' by one due to the shifting of the source range
' which is starting in column 'B'.
Dim CritColumn As Long
CritColumn = sws.Columns(CritColumnString).Column - 1
' Write the values from the source range to a 2D one-based array ('Data').
Dim Data() As Variant: Data = srg.Value
Dim sr As Long, sc As Long, dr As Long
' Write the rows, not containing the error value in the criteria column,
' to the top of the array.
For sr = 1 To rCount
If Not IsError(Data(sr, CritColumn)) Then
dr = dr + 1
For sc = 1 To cCount
Data(dr, sc) = Data(sr, sc)
Next sc
End If
Next sr
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Reference the destination range ('drg'), a range with the same address
' as the source range.
Dim drg As Range: Set drg = dws.Range(srg.Address)
With drg
' Write the values from the top of the array to the destination range.
.Resize(dr).Value = Data
' Clear below.
.Resize(dws.Rows.Count - .Row - dr + 1).Offset(dr).ClearContents
End With
' Inform.
MsgBox "Data copied.", vbInformation
End Sub
I've managed to compare 3 separate ranges on one workbook with 3 single ranges across 3 workbooks. Right now it's written to just pop up with a message box either letting me know the data is the same or the data is different. What I would like to do is for the macro to not only let me know there are differences, but to also highlight where the differences are to me. I guess this could be done by just highlighting the cells on the first workbook that are different to the other three or I guess it could also be done by pasting the different values on the sheets in question from COL N onward.
Sub Macro1()
Dim varDataMatrix() As Variant
Dim varDataMatrix2() As Variant
Dim varDataMatrix3() As Variant
Dim lngArrayCount As Long
Dim lngArrayCount2 As Long
Dim lngArrayCount3 As Long
Dim rngMyCell As Range
Dim rngMyCell2 As Range
Dim rngMyCell3 As Range
Dim wbWorkbookOne As Workbook
Dim wbWorkbookTwo As Workbook
Dim wbWorkbookThree As Workbook
Dim wbWorkbookFour As Workbook
Application.ScreenUpdating = False
Set wbWorkbookOne = Workbooks("PositionTest.xls")
Set wbWorkbookTwo = Workbooks("ATest.xlsx")
Set wbWorkbookThree = Workbooks("BTest.xlsx")
Set wbWorkbookFour = Workbooks("CTest.xlsx")
'First create an array of the values in the desired range of the first workbook.
For Each rngMyCell In wbWorkbookOne.Sheets("Positions").Range("B3:B6")
lngArrayCount = lngArrayCount + 1
ReDim Preserve varDataMatrix(1 To lngArrayCount)
varDataMatrix(lngArrayCount) = rngMyCell
Next rngMyCell
lngArrayCount = 0 'Initialise variable
'Loop through Array elements
For Each rngMyCell In wbWorkbookTwo.Sheets("A").Range("B2:B5")
lngArrayCount = lngArrayCount + 1
If rngMyCell.Value <> varDataMatrix(lngArrayCount) Then
GoTo QuitRoutinue
End If
Next rngMyCell
For Each rngMyCell2 In wbWorkbookOne.Sheets("Positions").Range("F3:F6")
lngArrayCount2 = lngArrayCount2 + 1
ReDim Preserve varDataMatrix2(1 To lngArrayCount2)
varDataMatrix2(lngArrayCount2) = rngMyCell2
Next rngMyCell2
lngArrayCount2 = 0 'Initialise variable
'Loop through Array elements
For Each rngMyCell2 In wbWorkbookThree.Sheets("B").Range("B2:B5")
lngArrayCount2 = lngArrayCount2 + 1
If rngMyCell2.Value <> varDataMatrix2(lngArrayCount2) Then
GoTo QuitRoutinue
End If
Next rngMyCell2
For Each rngMyCell3 In wbWorkbookOne.Sheets("Positions").Range("J3:J6")
lngArrayCount3 = lngArrayCount3 + 1
ReDim Preserve varDataMatrix3(1 To lngArrayCount3) 'Append the record to the existing array
varDataMatrix3(lngArrayCount3) = rngMyCell3
Next rngMyCell3
lngArrayCount3 = 0 'Initialise variable
For Each rngMyCell3 In wbWorkbookFour.Sheets("C").Range("B2:B5") 'Workbook one range is A10:A15 on 'Sheet2'.
lngArrayCount3 = lngArrayCount3 + 1
If rngMyCell3.Value <> varDataMatrix3(lngArrayCount3) Then
GoTo QuitRoutinue
End If
Next rngMyCell3
'If we get here both datasets have matched.
Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is the same.", vbInformation
Exit Sub
Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is different.", vbExclamation
End Sub
Highlights differences on Positions sheet and shows values in columns L to N. Uses Application.Transpose to create 1D arrays from a vertical range of cells. Note : Transpose won't work for a non-contiguous range.
Option Explicit
Sub Macro2()
Dim ws(3) As Worksheet, sht, w, n As Long
sht = Array("Positions", "A", "B", "C")
For Each w In Array("PositionTest.xls", "ATest.xlsx", "BTest.xlsx", "CTest.xlsx")
Set ws(n) = Workbooks(w).Sheets(sht(n))
n = n + 1
Next
Dim i As Long, r As Long, diff As Long
Dim rng0 As Range, rngN As Range, a As Range, b As Range
Dim ar0, arN
' compare sheets
For n = 1 To 3
Set rng0 = ws(0).Range("H5:H7,H9:H11,H13:H19,H21:H22").Offset(, (n - 1) * 4) ' H, L, P
Set rngN = ws(n).Range("E3:E18") ' sheet A, B, C
' copy to array
arN = Application.Transpose(rngN)
i = 0
For Each a In rng0
i = i + 1
r = a.Row
' cells on position sheet
Set b = ws(0).Cells(r, "R").Offset(, n) ' diff in col L,M,N
' compare arrays
If a.Value <> arN(i) Then
a.Interior.Color = RGB(255, 255, 0) ' yellow
b.Value = rngN.Cells(i, 1)
diff = diff + 1
Else
a.Interior.Pattern = False
b.Clear
End If
Next
Next
MsgBox diff & " differences", vbInformation
End Sub
The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function
Question regarding the code below. I need this randomizer to save the random entries that it created on a separated file without deleting previous entries that got saved, how should I proceed?
Private Sub CommandButton1_Click()
Dim lastRow As Long
Dim shAudit As Worksheet
Dim shData As Worksheet
Dim r As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim key As Variant
name = Range(A5, H9).Value
Set shAudit = ThisWorkbook.Sheets("Sheet1")
Set shData = ThisWorkbook.Sheets("Sheet2")
lastRow = shData.Range("A" & shData.Rows.Count).End(xlUp).Row
'Pick 5 random records with no repeats
Do Until dict.Count = 5
r = Application.WorksheetFunction.RandBetween(2, lastRow)
If Sheets("Sheet1").Range("A2") = Sheets("Sheet2").Cells(r, "G") Then
If Not dict.Exists(r) Then
dict.Add r, r
End If
End If
Loop
r = 0
For Each key In dict.Keys
shData.Range("A1:H1").Offset(key - 1, 0).Copy shAudit.Range("A5:H5").Offset(r, 0)
r = r + 1
Next key
End Sub
You can add this line just before End Sub. Change the sheet name to suit.
Worksheets("Sheet3").Range("A" & Rows.Count).End(xlUp)(2).Resize(dict.Count) = Application.Transpose(dict.keys)
My brain is fried and this is easy points for the usual suspects. div is an array holding sheet names. I am looping through sheets in a master book and if one of the master sheets match one of the sheets in the div array, I want to transfer some data from master sheet to a sheet in thisworkbook.
In the event the sheet does not exist in thisworkbook, add one and name it after the master sheet. What's the most efficient way to do this? I feel like nested loops is a bad idea -_- A collection perhaps?
For i = 0 To UBound(div())
For Each s In book.Worksheets
wsName = Left(s.Name, 5)
If div(i) = wsName Then
If wsExists(wsName) Then
Set ws = ThisWorkbook.Worksheets(wsName)
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = Left(s.Name, 5)
'Debug.Print "false " & ws.name
End If
end if
Next
With ws
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + label).Resize(, cols).Value = s.Columns(Start + label).Resize(, cols).Value
End With
Next
Do I even need to check if sheet exists? Code stolen from Tim.
Function wsExists(sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Edit: I am calling the loop from a separate routine.
Call drop(thisWB, thisRange, ccArr)
where ccArr is
Dim ccArr() As Variant
ccArr = Array("30500", "30510", "30515", "30530", "30600", "30900", "40500")
The routine where above loop resides opens with
Sub drop(book As Workbook, cols As Integer, div As Variant, Optional startCol As Integer)
but I am getting a byref error trying to pass the array ;_;
Your nested loop is superfluous. You can check the sheet name from div directly against the workbook you want to check it against, then add it if needed.
See the code below, which also addresses the concerns in the edits to your OP. I modified the wsExists function to include a set reference to a particular workbook, which I think makes it more dynamic.
'assumes thisWB and thisRange set above
Dim ccArr() As String, sList As String
sList = "30500,30510,30515,30530,30600,30900,40500"
ccArr = Split(sList, ",")
drop thisWB, thisRange, ccArr 'assumes thisWb and thisRange are set already
' rest of code
'==================================================
Sub drop(book As Workbook, cols As Integer, div() As String, Optional startCol as Integer)
For i = 0 To UBound(div())
If wsExists(ThisWorkbook, div(i)) Then
Set ws = ThisWorkbook.Worksheets(div(i))
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = div(i)
End If
'i think you need this here, otherwise, it will only work on the last worksheet in your loop
With ws
Dim s As Worksheet
Set s = book.Sheets(div(i))
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + Label).Resize(, cols).Value = s.Columns(Start + Label).Resize(, cols).Value
End With
Next
End Sub
Function wsExists(wb As Workbook, sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Related to the re-sizing code:
This statement ws.Columns(1).Resize(, 2) translates to "2 million+ rows from column 1 and 2"
The solution you found works well but it's not dynamic (hard-coded last row)
This is how I'd setup the copy of columns:
Option Explicit
Public Sub copyCols()
Dim ws1 As Worksheet, ws2 As Worksheet, rng1 As Range, rng2 As Range
Dim cols As Long, lr As Long
Dim col1 As Long 'renamed from "Start" (VBA keyword - property)
Dim lbl As Long 'renamed from "label" (VBA keyword - Control object)
Set ws1 = Sheet1 'ws
Set ws2 = Sheet2 'book.Worksheets(wsName & "-F")
col1 = 1
cols = 2
lbl = 1
lr = ws2.Cells(ws2.UsedRange.Row + ws2.UsedRange.Rows.Count, "A").End(xlUp).Row
Set rng1 = ws1.Range(ws1.Cells(1, col1), ws1.Cells(lr, col1 + 1))
Set rng2 = ws2.Range("A1:B" & lr)
rng1.Value2 = rng2.Value2
Set rng1 = ws1.Range(ws1.Cells(1, col1 + lbl), ws1.Cells(lr, col1 + lbl + cols))
Set rng2 = ws2.Range(ws2.Cells(1, col1 + lbl), ws2.Cells(lr, col1 + lbl + cols))
rng1.Value2 = rng2.Value2
End Sub