After all of these years, I've seen several questions that asks how to populate an Array with a Recordset, but none that addresses how to write the output onto a worksheet all in one procedure. So, I decided to ask the Question in order to provide an answer that I've developed over time.
'Goes on Top
Option Explicit
Option Compare Text
Option Base 1
Public Sub Recordset_to_Array_to_Worksheet()
Dim MyArray() As Variant 'unbound Array with no definite dimensions'
Dim db as DAO.Database
Dim rst as DAO.Recordset
Dim strSQL as String, Fieldname as String
Dim i as Integer, j as Integer, colcnt as Integer, rowcnt as Integer
Dim wb as Workbook
Dim ws as Worksheet
Dim Dest as Range
'------------------------RECORDSET------------------------'
Set db = Opendatabase("URL link") 'or Set db = Currentdb()
strSQL = "SQL Statement Here"
Set rst = db.OpenRecordset(strsQL, dbOpenDynaset)
If rst.recordcount <> 0 then '///Do NOT Use "Do While Not rst.EOF" Can cause Problems///'
colcnt = rst.Fields.Count-1
rowcnt = rst.recordcount
Else
Exit Sub
End IF
'-----------------------------WRITE RECORDSET TO MYARRAY----------------------------'
ReDim MyArray (rowcnt, colcnt) 'Redimension MyArray parameters to fit the SQL returned'
rst.MoveFirst
'Populating Array with Headers from Recordset'
For j = 0 To colcnt
MyArray(0,j) = rst.Fields(j).name
Next
'Populating Array with Record Data
For i = 1 to rowcnt
For j = 0 to colcnt
MyArray(i,j) = rst(j)
Next J
rst.movenext
Next i
'---------------------------------WORKSHEET OUTPUT---------------------------------'
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Insert Worksheet Name")
Set Dest = ws.Range("A1") 'Destination Cell
Dest.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).value =
Application.Transpose(MyArray) 'Resize (secret sauce)
End Sub
Related
I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.
Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":
Sub TransposeMails()
Dim sh As Worksheet, lastR As Long, lastCol As Long
Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column
arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2 'place the range to be processed (except headers) in an array for faster iteration/processing
ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
'+ 1 for the empty rows in between...
For i = 1 To UBound(arr)
For j = 1 To UBound(arrH)
k = k + 1
arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
Next j
k = k + 1 'for the empty row between groups...
Next i
'drop the processed array content:
sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub
The code can be easily adapted to return anywhere (another sheet, workbook, range etc).
The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...
Transpose Data
Sub TransposeData()
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet1"
Const DST_FIRST_CELL As String = "A8"
Const EMPTY_COLS As Long = 0
Const EMPTY_ROWS As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Application.ScreenUpdating = False
Dim srrg As Range, shrg As Range
Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
For Each srrg In srg.Rows
If Not IsHeaderReady Then
srrg.Copy
dfCell.PasteSpecial Transpose:=True
Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
IsHeaderReady = True
Else ' header is ready; it's already copied for the first data row
If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
srrg.Copy
dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
Set dfCell = dfCell.Offset(drOffset)
End If
Next srrg
Application.ScreenUpdating = True
MsgBox "Data transposed.", vbInformation
End Sub
If I understand you correctly
Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range
'loop to each range with data as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)
For i = 1 To cnt
Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
.Resize(rg.Columns.Count, 1)
rslt.Value = Application.Transpose(rg)
rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
Next
End Sub
Please note, the code must be run where the sheet contains the data is active.
I have a code that copies data from different workbooks to an array and transfers that data to a table I want to keep the filter method with a slicer on the workbook I copy that data from but to copy only the filtered data.
on the workbook I am copying to I want only the filtered that to be seen
Does anyone have suggestions?
I commented out the offset because the code doesn't work i need the offset in order not to copy the header row
Sub readingarray()
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Dim arr As Variant
Dim tbl As Range
Set tbl = Workbooks("test.xlsm").Worksheets("shibuz").Range("T4").CurrentRegion.SpecialCells(xlCellTypeVisible)
'arr = tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count)
arr = tbl
Set table_list_object = Workbooks("shibuzim 2 updated.xlsm").Worksheets("shibuz").ListObjects("LeaveTracker")
Set table_object_row = table_list_object.ListRows.Add
Dim rowcount As Long, columncount As Long
rowcount = UBound(arr, 1)
columncount = UBound(arr, 2)
table_object_row.Range(1, 1).Resize(rowcount, columncount).Value = arr
End Sub
solved it, hopes this might help
Option Explicit
Sub readingarray()
Application.DisplayAlerts = False
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Dim arr
Dim Itm
Dim rng As Range
Dim stringarray As Variant
Dim rowcount As Long, columncount As Long
stringarray = Array("test.xlsm", "test 2.xlsm")
On Error Resume Next
For Each Itm In stringarray
arr = GetArrayFromFilteredRange(Workbooks(Itm).Worksheets("shibuz").ListObjects("LeaveTracker").DataBodyRange.SpecialCells(xlCellTypeVisible))
Set table_list_object = Workbooks("shibuzim 2 updated.xlsm").Worksheets("shibuz").ListObjects("LeaveTracker")
Set table_object_row = table_list_object.ListRows.Add
rowcount = UBound(arr, 1)
columncount = UBound(arr, 2)
table_object_row.Range(1, 1).Resize(rowcount - 1, columncount - 1).Value = arr
Next Itm
On Error GoTo 0
End Sub
Function GetArrayFromFilteredRange(rng As Range) As Variant
Dim arr As Variant
helper.Cells.Clear
rng.Copy helper.Range("A1")
arr = helper.UsedRange.Value
GetArrayFromFilteredRange = arr
End Function
I have a procedure to create a new sheet based on available data. Basically, it creates a sheet based on the name of the data. The code is written as follows. It does work actually if I assign the procedure one by one.
Sub new_profile(tankname)
Sheets.Add After:=ActiveSheet
Range("B4").Select
ActiveCell.FormulaR1C1 = tankname
ActiveSheet.Name = Range("b4").Value
end sub
Due to the fact that I will use this code for another workbook (which means there is no exact amount of data), I try to assign an array to automatically run the procedure all in one without call it one by one. The code is as follow:
Sub calculate_all()
Dim cel As Range
Dim tank_name() As String
Dim i As Integer, j As Integer
Dim n As Integer
i = 11
n = Range("B6").Value
ReDim tank_name(i)
For Each cel In ActiveSheet.Range(Cells(11, 2), Cells(11 + n, 2))
tank_name(i) = cel.Value
i = i + 1
new_profile tank_name(i)
ReDim Preserve tank_name(i)
Next cel
End Sub
Unfortunately, it becomes error and shows the message "subscript out of range". How could I solve this problem?
For Each Element in Array Run a Procedure
Let's say that creating a new profile means adding a new sheet, renaming it and writing the name to a cell.
The 1st, main procedure createProfiles does the previously mentioned only if a worksheet with the current name in the TankNames array doesn't exist.
The 2nd procedure deleteProfiles deletes all sheets if their names exist in the TankNames array.
The 3rd and the 4th procedure are called by both previously mentioned procedures, while the 5th is obviously only called by the main procedure.
Before running any of the first two procedures, adjust the constants in them to fit your needs.
The Code
Option Explicit
Sub createProfiles()
' Source
Const wsName As String = "Sheet1" ' Tab Name
Const FirstRow As Long = 11
Const NameCol As Variant = "B" ' e.g. 1 or "A", 2 or "B"...
' Target
Const CellAddress As String = "B4"
' Other
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Worksheet.
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Write tank names from Source Worksheet to TankNames array.
Dim TankNames As Variant
getColumn TankNames, ws, NameCol, FirstRow
Dim i As Long
' Loop through elements of TankNames array.
For i = 1 To UBound(TankNames)
' For each tank name create a new profile.
If Not foundSheetName(wb, TankNames(i, 1)) Then
Call createProfile wb, TankNames(i, 1), CellAddress
End If
Next i
End Sub
Sub deleteProfiles()
' Source
Const wsName As String = "Sheet1" ' Tab Name
Const FirstRow As Long = 11
Const NameCol As Variant = "B" ' e.g. 1 or "A", 2 or "B"...
' Other
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Worksheet.
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Write tank names from Source Worksheet to TankNames array.
Dim TankNames As Variant
getColumn TankNames, ws, NameCol, FirstRow
Dim i As Long
' Loop through elements of TankNames array.
For i = 1 To UBound(TankNames)
' For each tank name delete profile (sheet).
If foundSheetName(wb, TankNames(i, 1)) Then
Application.DisplayAlerts = False
wb.Worksheets(TankNames(i, 1)).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
Sub getColumn(ByRef Data As Variant, _
Sheet As Worksheet, _
Optional ByVal ColumnID As Variant = 1, _
Optional ByVal FirstRow As Long = 1)
Data = Empty
If Sheet Is Nothing Then Exit Sub
Dim rng As Range
Set rng = Sheet.Columns(ColumnID).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Sheet.Range(Sheet.Cells(FirstRow, ColumnID), rng)
If rng.Cells.Count > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
End If
End Sub
Function foundSheetName(Book As Workbook, _
Optional ByVal SheetName As String = "Sheet1") _
As Boolean
If Book Is Nothing Then Set Book = ActiveWorkbook
On Error Resume Next
Dim ws As Worksheet: Set ws = Book.Worksheets(SheetName)
If Err.Number = 0 Then foundSheetName = True
End Function
Sub createProfile(Book As Workbook, _
ByVal NewName As String, _
ByVal NameCellAddress As String)
Dim ws As Worksheet
Set ws = Book.Worksheets.Add(After:=Book.Sheets(Book.Sheets.Count))
With ws
.Name = NewName
.Range(NameCellAddress) = NewName
End With
End Sub
I'm trying to copy worksheets from a master workbook to a target workbook but the sheets that I copy are different depending on if the value in rngCurrent is present in the worksheet name. For some reason I keep getting a subscript out or range error on the last line. Can anyone help me understand what's going on?
Sub test2()
Dim wb As Workbook
Dim master As Workbook
Dim wbCurrent As Workbook
Dim wbAdjustments As Workbook
Dim wsName As Worksheet
Dim rngEntityList As Range
Dim rngCurrentEntity As Range
Dim rngCurrent As Range
Dim arrWorksheets As Variant
Dim i As Integer
Dim wsCount As Integer
Set master = ThisWorkbook
Set rngCurrentEntity = master.Sheets("File Info").Range("rng_Entity") 'named range of single entity
Set rngEntityList = master.Sheets("Global").Range("rng_EntityList") 'list or entities
Set rngCurrent = rngEntityList.Find(rngCurrentEntity.Value, LookIn:=xlValues) ' find single entity in the list
If rngCurrent.Offset(, 4).Value = "FRP" Then 'find if it's FRP
Set wb = Application.Workbooks("Foreign.xlsx")
Else
Set wb = Application.Workbooks("Domestic.xlsx")
End If
Dim ws() As String ' declare string array
ReDim ws(wb.Worksheets.Count) As String ' set size dynamically
Dim counter As Long ' running counter for ws array
counter = 1
For i = 1 To wb.Worksheets.Count
If InStr(1, wb.Worksheets(i).Name, rngCurrent.Value) <> 0 Then
ws(counter) = wb.Worksheets(i).Name
counter = counter + 1
End If
Next
ReDim Preserve ws(counter) As String ' Get rid of empty array entries
wb.Worksheets(ws).Copy After:=master.Worksheets(master.Worksheets.Count)
End Sub
EDIT
The reason I need to do it this way is because I don't want the external links to the source notebook.
Complete and tested example
Sub Tester()
Dim wb As Workbook, i As Long
Set wb = ThisWorkbook
Dim ws() As String ' declare string array
ReDim ws(1 To wb.Worksheets.Count) As String ' set size dynamically
Dim counter As Long ' running counter for ws array
counter = 0
For i = 1 To wb.Worksheets.Count
If InStr(1, wb.Worksheets(i).Name, "test") <> 0 Then
counter = counter + 1
ws(counter) = wb.Worksheets(i).Name
End If
Next
ReDim Preserve ws(1 To counter)
wb.Worksheets(ws).Copy 'just makes a copy in a new workbook
End Sub
do this:
ReDim ws(1 To wb.Worksheets.count) As String ' set size dynamically, start from 1
Dim counter As Long ' running counter for ws array
For i = 1 To wb.Worksheets.count
If InStr(1, wb.Worksheets(i).name, rngCurrent.Value) <> 0 Then
counter = counter + 1 '<--| update counter
ws(counter) = wb.Worksheets(i).name
End If
Next
I have an Excel sheet having 3000 columns and I need to convert this sheet in such a way that one tab will contain 254 columns only and remaining will go to the next tab. So I need a VBA code (Macro) which can perform the same.
As of now I wrote the following code only which is creating 3000 tabs with one column in each, also it is going to infinite loop as I did not put any condition there for blank column.
Sub SpliteIntoMultipleTab()
'
' createtemplates Macro
Dim WS As Worksheet
Dim SS As Worksheet
Dim TemplateName As String
Dim tempstr As String
'
Dim CurCol As String
Dim Template As String
Dim xColIndex As Integer
Dim xRowIndex As Integer
Dim WSCount As Integer
'==========================================================================
'Declarations
CurCol = 1
Template = "Sheet1"
'==========================================================================
Set SS = Worksheets(Template)
If WS Is Nothing Then
Start:
With ActiveWorkbook
Set WS = .Sheets.Add(After:=ActiveSheet)
WSCount = Sheets.Add(After:=Sheets(Worksheets.Count))
On Error Resume Next
Set WS = Worksheets("temp")
WS.Name = SS.Range("A1").Value
End With
Else
End If
SS.Activate
xIndex = Application.ActiveCell.Column
xRowIndex = Application.ActiveSheet.Cells(Rows.Count, xIndex).End(xlUp).Row
Range(Cells(1, xIndex), Cells(xRowIndex, xIndex)).Select
Selection.Copy
WS.Select
WS.Range("A1").Select
ActiveSheet.Paste
SS.Columns(1).EntireColumn.Delete
CurCol = CurCol + 1
GoTo Start
End Sub
Use integer division and modulus, so for example taking the 1000th column
1000 \ 254 = 3
1000 mod 254 = 238
gives the 3rd sheet and the 238th column.
So loop through from 1 to 3000 using \ and mod.
You code is very non-standard and I cannot get my head around it, I suggest you start from my code, this is an illustrative example of breaking a block of data into separate sheets. Copy the code into a new workbook then
Run CreateSheetAndPopulateWithBlockOfData once only to create a block of data.
Run Test to run the BreakBlockIntoChunks routine, you can experiment with the chunk size.
Option Explicit
Private Const csSHEETNAME As String = "Source"
Sub TestCreateSheetAndPopualteWithBlockOfData()
Dim wsSource As Excel.Worksheet
Set wsSource = CreateSheetAndPopulateWithBlockOfData(ThisWorkbook, csSHEETNAME, 20, 100)
End Sub
Sub Test()
Dim wsSource As Excel.Worksheet
Set wsSource = ThisWorkbook.Worksheets.Item(csSHEETNAME)
'Stop
Dim wbResults As Excel.Workbook
Set wbResults = Workbooks.Add
BreakBlockIntoChunks wsSource, 5, wbResults
End Sub
Function BreakBlockIntoChunks(ByVal wsSource As Excel.Worksheet, ByVal lColumnChunkSize As Long, ByVal wbDestinationWorkbook As Excel.Workbook)
Dim rngDataBlock As Excel.Range
Set rngDataBlock = wsSource.Cells(1, 1).CurrentRegion
Dim lSourceColumnCount As Long
lSourceColumnCount = rngDataBlock.Columns.Count
Dim lSourceRowCount As Long
lSourceRowCount = rngDataBlock.Rows.Count
Dim lColumnLoop As Long
For lColumnLoop = 1 To lSourceColumnCount
Dim lCurrentSheet As Long
lCurrentSheet = ((lColumnLoop - 1) \ lColumnChunkSize) + 1
Dim wsCurrentSheet As Excel.Worksheet
If lCurrentSheet > wbDestinationWorkbook.Worksheets.Count Then Set wsCurrentSheet = wbDestinationWorkbook.Worksheets.Add
If wsCurrentSheet Is Nothing Then Set wsCurrentSheet = wbDestinationWorkbook.Worksheets.Item(lCurrentSheet) '* runs first loop
'**ADD your sheet naming logic here perhaps
Dim lCurrentColumn As Long
lCurrentColumn = ((lColumnLoop - 1) Mod lColumnChunkSize) + 1
Dim rngSource As Excel.Range
Set rngSource = wsSource.Range(wsSource.Cells(1, lColumnLoop), wsSource.Cells(lSourceRowCount, lColumnLoop))
Dim rngDestination As Excel.Range
Set rngDestination = wsCurrentSheet.Range(wsCurrentSheet.Cells(1, lCurrentColumn), wsCurrentSheet.Cells(lSourceRowCount, lCurrentColumn))
rngDestination.Value2 = rngSource.Value2 '* <---Copies without using clipboard
Next lColumnLoop
End Function
Function CreateSheetAndPopulateWithBlockOfData(ByVal wb As Excel.Workbook, ByVal sSheetName As String, ByVal lRowsDeep As Long, ByVal lColumnsWide As Long) As Excel.Worksheet
Dim ws As Excel.Worksheet
Set ws = wb.Worksheets.Add
ws.Name = sSheetName
Dim rngBlock As Excel.Range
Set rngBlock = ws.Range(ws.Cells(1, 1), ws.Cells(lRowsDeep, lColumnsWide))
rngBlock.Formula = "=RANDBETWEEN(1,100000)"
rngBlock.Value2 = rngBlock.Value2
Set CreateSheetAndPopulateWithBlockOfData = ws
End Function
you could try this:
Sub SpliteIntoMultipleTab()
Dim colNum As Long, iCol As Long
With Worksheets("Sheet1").UsedRange
colNum = .Columns.count
Do
Worksheets.Add(After:=Worksheets(Worksheets.count)).Range("A1:IT1").Resize(.Rows.count).Value = .Columns(iCol + 1).Resize(, 254).Value
iCol = iCol + 254
colNum = colNum - 254
Loop While colNum > 0
End With
End Sub
which copies values only and speed up things considerably