Related
Is there a clean and tidy way to get cells split ONLY by sheet name? I have a bunch of cells that look something like this.
=(Xlookup($A2,Staff!A:A,Client!K:K)*E2
=B3*(Xlookup(E3,Auto!1:1,Desc!3:3)
And, all kinds of other stuff. Basically, I am trying to parse out only the sheet names from each cell. Each sheet name ends with a '!' character. So, I am trying to split one cell into multiple columns, based on the '!' character, and ignore any text that is not a sheet name. I tested the script below, but all it does is a basic split from one cell into multiple columns, which includes the sheet name, but all kinds of superfluous text, which I don't want.
Sub SplitData()
Const SrcCol = 1 ' A
Const TrgCol = 2 ' B
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim TheVal As String
Dim TheArr As Variant
Dim Num As Long
Application.ScreenUpdating = False
TrgRow = 1
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
TheVal = Cells(SrcRow, SrcCol).Value
TheArr = Split(TheVal, ",")
Num = UBound(TheArr) + 1
Cells(TrgRow, TrgCol).Resize(ColumnSize:=Num).Value = TheArr
TrgRow = TrgRow + 1
Next SrcRow
Application.ScreenUpdating = True
End Sub
Now:
Desired:
If you have O365, this will work for you ...
=LET(x, TRANSPOSE(FILTERXML("<d><r>" & SUBSTITUTE(A1, ",", "</r><r>") & "</r></d>", "//r[contains(text(),""!"")]")), MID(x, 1, FIND("!", x)))
... here's hoping you do, a lot easier.
Alternatively, I created my own VBA routine with the assumption that everything to the right of the formula is free to load into, just adjust for errors, names, performance, etc. as required ...
Public Sub GetWorksheets()
Dim lngRow As Long, lngColumn As Long, strFormula As String
Dim arrFormula() As String, i As Long, arrSubFormula() As String
With Sheet1
For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
strFormula = Trim(.Cells(lngRow, 1))
lngColumn = 2
If strFormula <> "" Then
arrFormula = Split(strFormula, "!")
For i = 0 To UBound(arrFormula) - 1
arrSubFormula = Split(arrFormula(i), ",")
strFormula = arrSubFormula(UBound(arrSubFormula)) & "!"
.Cells(lngRow, lngColumn) = strFormula
lngColumn = lngColumn + 1
Next
End If
Next
End With
End Sub
I'm writing a VBA program which copies and organizes data from one master sheet into numerous other sheets. One of the recipient sheets unifies all the data from the master sheet which holds the same id number into a single row. For this operation, I am looping through the master sheet for each id number, copying each row which holds the current id number into a new sheet purely used for calculations and organizing, and rearranging the data in this sheet into the new row. The resultant row is copied into the recipient sheet. This process of organizing data for every id number takes a long time to process, especially given the very large size of this sheet and the processing time of the other recipient sheets. I'm wondering if there is a better way to organize and copy data without using an intermediate calculation sheet.
The below code is the main sub, which calls another sub OrganizeAndCopyToPal, which organizes the data in the calculation sheet and copies the result into the recipient sheet.
Sub PalletAssemblyLog()
Dim allidNum As Range
Dim curridNum As Range
Dim rowCount As Long
Dim idNum
Dim I As Long
Dim j As Long
Dim machineLoc As String
Dim calc As Worksheet
Dim full As Worksheet
Dim pal As Worksheet
Set calc = Sheet3
Set full = Sheet4
Set pal = Sheet1
For I = 2 To rowCount
For j = 2 To rowCount
If full.Cells(j, 17).Value = idNum Then
If allidNum Is Nothing Then
Set allidNum = full.Cells(j, 17)
Else
Set allidNum = Union(allidNum, full.Cells(j, 17))
End If
End If
Next j
Set curridNum = allidNum.EntireRow
calc.Activate
calc.Cells.Clear
full.Activate
curridNum.Copy calc.Range("A1")
OrganizeAndCopyToPal curridNum
Next I
End Sub
The below sub organizes and copies the data for each id number. The final sub to copy the data isn't related to the matter of simplifying this task so I'm not including it.
Sub OrganizeAndCopyToPal(curridNum)
Dim calc As Worksheet
Dim pal As Worksheet
Set calc = Sheet3
Set pal = Sheet1
calc.Activate
Dim rowCount As Long
rowCount = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim palRow As Long
palRow = rowCount + 2
Dim partRow As Long
partRow = palRow + 2
Dim currPartCount As Range
Dim assembly As String
Dim id As String
Dim location As String
Dim machType As String
Dim machLoc As String
Dim currPart As String
Dim link As String
Dim tot As Long
tot = 0
With calc
.Cells(1, 1).Copy .Cells(palRow, 2)
assembly = .Cells(1, 1).Value
.Cells(1, 2).Copy .Cells(palRow, 5)
id = .Cells(1, 17).Value
asArray = SplitMultiDelims(id, "|-")
'MsgBox asArray(0) & " " & asArray(1) & " " & asArray(2)
machArray = Split(.Cells(1, 8), "-")
machType = machArray(0)
.Cells(palRow, 3) = machType
machLoc = .Cells(1, 8).Value
.Cells(palRow, 4) = machLoc
.Cells(1, 17).Copy .Cells(palRow, 10)
location = Cells(1, 9)
.Cells(palRow, 1) = location
For I = 1 To rowCount
partArray = Split(.Cells(I, 16).Value, ",")
For j = 0 To UBound(partArray)
partArray2 = Split(partArray(0), "-")
partPrefix = partArray2(0)
If j = 0 Then
currPart = partArray(j)
Else
currPart = partPrefix & "-" & CStr(partArray(j))
End If
tf = 1
For k = 0 To tot
If Cells(partRow + k, 1).Value = currPart Then
tf = 0
Exit For
End If
Next k
If tf = 1 Then
.Cells(partRow + tot, 1).Value = currPart
tot = tot + 1
End If
Next j
Next I
For I = 1 To tot
Cells(palRow, 10 + I).Value = Cells(partRow + I - 1, 1)
Next I
End With
CopyToPal curridNum, palRow
End Sub
Thank you for any tips or help that you can offer.
Before getting into more exotic solutions - the easiest thing you can do is set
Application.Calculation = xlCalculationManual
Before getting stuck into much code.
Then when you need to do an update before copying any data that may change due to formulae calcs, run
Application.Calculate
and eventually at the end reset it to
Application.Calculation = xlCalculationAutomatic
You can disable screen updates too, but the above will be the big (easy) one. After that we're into copying to arrays and working in them then pasting back.
I have 2 columns on a sheet "list", one column that lists all business entities, the other lists all org units. The functionality of the code below works perfectly but returns an error because it exceeds the sheet row limit.
The data is pasted onto a sheet "cc_act" is there a way to at point of error create a new sheet called "cc_act1"...."cc_act2" until the script is complete?
Declare Function HypMenuVRefresh Lib "HsAddin" () As Long
Sub cc()
Application.ScreenUpdating = False
Dim list As Worksheet: Set list = ThisWorkbook.Worksheets("list")
Dim p As Worksheet: Set p = ThisWorkbook.Worksheets("p")
Dim calc As Worksheet: Set calc = ThisWorkbook.Worksheets("calc")
Dim cc As Worksheet: Set cc = ThisWorkbook.Worksheets("cc_act")
Dim cc_lr As Long
Dim calc_lr As Long: calc_lr = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim calc_lc As Long: calc_lc = calc.Cells(1,
calc.Columns.Count).End(xlToLeft).Column
Dim calc_rg As Range
Dim ctry_rg As Range
Dim i As Integer
Dim x As Integer
list.Activate
For x = 2 To Range("B" & Rows.Count).End(xlUp).Row
If list.Range("B" & x).Value <> "" Then
p.Cells(17, 3) = list.Range("B" & x).Value
End If
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If list.Range("A" & i).Value <> "" Then
p.Cells(17, 4) = list.Range("A" & i).Value
p.Calculate
End If
p.Activate
Call HypMenuVRefresh
p.Calculate
'''changes country on calc table
calc.Cells(2, 2) = p.Cells(17, 4)
calc.Cells(2, 3) = p.Cells(17, 3)
calc.Calculate
'''copy the calc range and past under last column
With calc
Set calc_rg = calc.Range("A2:F2" & calc_lr)
End With
With cc
cc_lr = cc.Cells(Rows.Count, "A").End(xlUp).Row + 1
calc_rg.Copy
cc.Cells(cc_lr, "A").PasteSpecial xlPasteValues
End With
Next i
Next x
Application.ScreenUpdating = True
End Sub
I suppose there are a few ways to handle something like this. See the code sample below, and adapt it to your specific needs.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
As an aside, you may want to consider using MS Access for this kind of thing. Or, better yet, Python or even R. Good luck with your project.
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True
I have many, over two dozen (and counting), data sets with 15000 rows and 36 columns each, that I would like to combine. These data sets are have the same columns and more or less the same rows. They are monthly snapshots of the same data, with some data leaving and some entering (hence the marginally different number of rows.
I would like the user to select some of them and and combine them. The name of the file contains that date and my code extracts the date and adds it in a new column at the end. Right now, my code works. I collect all the data in a three dimensional array and then paste it in a new workbook. The problem is that since each book has different numbers or rows, I am creating a data array with more rows than needed. So my data has a lot of empy rows right now. I guess I can delete the empty rows in the end. I am new to excel VBA and new to doing data work so I was wondering if there was a smarter, more efficient way of construction my panel.
Dim DataArray As Variant
Sub test()
Dim filespec As Variant, i As Integer
ReDim DataArray(0 To 20000, 0 To 36, 0 To 0)
' Here the user gets to select the files
On Error GoTo EndNow
filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)
For i = 1 To UBound(filespec)
ReDim Preserve DataArray(0 To 20000, 0 To 36, 0 To i)
Set wbSource = Workbooks.Open(filespec(i))
Set ws1 = wbSource.Worksheets("Sheet1")
With ws1
'now I store the values in my array
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
For j = 1 To FinalRow
For k = 1 To FinalColumn
DataArray(j, k, i) = .Cells(j, k).Value
Next k
' Now I extract the date data from the file name and store it in the last column of my array.
DataArray(j, FinalColumn + 1, i) = piece(piece(GetFileName(CStr(filespec(i))), "_", 3), ".", 1)
Next j
End With
ActiveWorkbook.Close
Next i
Set wb2 = Application.Workbooks.Add
Set ws2 = wb2.Worksheets("Sheet1")
With ws2
For i = 1 To UBound(DataArray, 3)
FinalRow2 = 20000
FinalColumn2 = 36
For k = 1 To FinalColumn2
' I did this If loop so as to not copy headers every time.
If i = 1 Then
For j = 1 To FinalRow2
.Cells(j, k).Value = DataArray(j, k, i)
Next j
Else
For j = 2 To FinalRow2
.Cells(FinalRow2 * (i - 1) + j, k).Value = DataArray(j, k, i)
Next j
End If
Next k
Next i
wb2.Sheets(1).Name = "FolderDetails Panel Data"
wb2.SaveAs ThisWorkbook.Path & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End With
EndNow:
End Sub
' MsgBox GetFileName(filespec(0))
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Function piece(Searchstring As String, Separator As String, IndexNum As Integer) As String
Dim t
t = Split(Searchstring, Separator)
If UBound(t) > 0 Then piece = t(IndexNum - 1)
End Function
To answer your direct question, I would copy the data from each workbook into the merged workbook as each is processed. I see no advantage in collecting all the data into a 3D array.
There are also many other issues with your code. What follows is a refactor of your code, with changes highlighted.
Option Explicit ' <-- Force declaration of all variables (must be first line in module)
Sub Demo()
Dim filespec As Variant
Dim i As Long ' --> Long is prefered over Integer
Dim DataArray As Variant ' <-- no need to be Module scoped
' --> Declare all your variables
Dim j As Long, k As Long
Dim wbSource As Workbook
Dim ws As Worksheet
Dim wbMerged As Workbook
Dim wsMerged As Worksheet
Dim DataHeader As Variant
Dim FinalRow As Long, FinalColumn As Long
Dim sDate As String
Dim rng As Range
' Here the user gets to select the files
On Error GoTo EndNow
filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)
If Not IsArray(filespec) Then
' <-- User canceled
Exit Sub
End If
' Speed up processing <--
' -- Comment these out for debugging purposes
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
' Create Merged Workbook
Set wbMerged = Application.Workbooks.Add
Set wsMerged = wbMerged.Sheets(1)
wsMerged.Name = "FolderDetails Panel Data"
For i = 1 To UBound(filespec)
Set wbSource = Workbooks.Open(filespec(i))
Set ws = wbSource.Worksheets("Sheet1")
With ws
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Cells(.Rows.Count, 2).End(xlUp).Row
If i = 1 Then
' Get header from first workbook only
DataHeader = Range(.Cells(1, 1), .Cells(1, FinalColumn)).Value ' <-- Get data header
ReDim Preserve DataHeader(1 To 1, 1 To UBound(DataHeader, 2) + 1) ' <-- Range.Value arrays are 1 based
k = UBound(DataHeader, 2)
DataHeader(1, k) = "Date" ' <-- Header
End If
' Get all data in one go, excluding header
DataArray = Range(.Cells(2, 1), .Cells(FinalRow, FinalColumn)).Value ' <-- Array size matches data size
End With
wbSource.Close False
' Add Date to data
sDate = GetDateFromFileName(filespec(i)) '<-- do it once
' resize data array
ReDim Preserve DataArray(1 To UBound(DataArray, 1), 1 To UBound(DataArray, 2) + 1) ' <-- Range.Value arrays are 1 based
' Add date data
For j = 1 To UBound(DataArray, 1)
DataArray(j, k) = sDate
Next j
' Complete processing of each workbook as its opened
With wsMerged
' Add header row from first workbook
If i = 1 Then
Range(.Cells(1, 1), .Cells(1, UBound(DataArray, 2))) = DataHeader
End If
' <-- Add data to end of sheet
' Size the destination range to match the data
Set rng = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1)
Set rng = rng.Resize(UBound(DataArray, 1), UBound(DataArray, 2))
rng = DataArray
End With
Next i
' <-- append \ to path
wbMerged.SaveAs ThisWorkbook.Path & "\" & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
EndNow:
MsgBox "Oh dear"
GoTo CleanUp
End Sub
' Simplified
' <-- Not entirely sure if this will match your file name pattern.
' Please check
' Assumed file name
' Some\Path\Some_Words_YYYMMDD.xls
Function GetDateFromFileName(Nm As Variant) As String
Dim str As String
str = Mid$(Nm, InStrRev(Nm, "\") + 1)
str = Left$(str, InStrRev(str, ".") - 1)
str = Mid$(str, InStrRev(str, "_") + 1)
GetDateFromFileName = str
End Function