i need a macro to select some objects (rows) of the big database with over 500 rows and copy 12 of the 44 columns into an array and reorder them into an comparison table. I need the column headers reordered as row headers.
The goal is to export the new ordered comparison table into an existing powerpoint template. I will try to not copy the entire columns and just to copy the columns i need.
I'm new to Vba and would appreciate any help.
This is my code for reading the data so far:
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Myarray As Variant
Dim LastRow As Integer, LastColumn As Integer
Dim StartCells As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1") Google Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set StartCell = ws1.Range("A1")
LastRow = ws1.Cells(ws1.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = ws1.Cells(StartCell.Row,ws1.Columns.Count).End(xlToLeft).Column
My fake dataset is like this:
You said I need the column headers reordered as row headers. so you need to transpose.
In my code I'm using columns 2,5,6 and 8 but you can change this easily.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Myarray() As Variant
Dim LastRow As Integer, LastColumn As Integer
Dim StartCell As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim i As Long
Dim j As Long
Set StartCell = ws1.Range("A1")
LastRow = ws1.Cells(ws1.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = ws1.Cells(StartCell.Row, ws1.Columns.Count).End(xlToLeft).Column
'copy specific columns into worksheet 2
j = 1
For i = 1 To LastColumn Step 1
Select Case i
Case 2, 5, 6, 8 'target columns to copy
With ws1
Myarray() = .Range(.Cells(1, i), .Cells(LastRow, i)).Value
End With
With ws2
.Range(.Cells(j, 1), .Cells(j, LastRow)) = Application.WorksheetFunction.Transpose(Myarray())
End With
j = j + 1
Case Else
End Select
Next i
Erase Myarray()
End Sub
Output I get:
Related
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
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'm searching a range in my sheet for certain values when either of these values is found I want to add the value from column A of that row to an array, only adding values that are not already present in the array. Once the range has been searched, I want to print the arrays to specified cells in the worksheet in 2 different columns.
Here's my code so far:
Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
Dim Leave() As Variant, Join() As Variant
Dim LastCol As Integer, LastRow As Integer, i As Integer, Z As Integer
Dim J As Long, L As Long
With Sheets("Sheet1")
'Find Last Col
LastCol = Sheets("Sheet1").Cells(3, Columns.Count).End(xlToLeft).Column
'Find last Row
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRow = LastRow - 1
'ReDim Leave(1 To (LastRow - 1), LastCol)
'ReDim Join(1 To (LastRow - 1), LastCol)
For i = 5 To LastCol
For Z = 4 To LastRow
If Sheets("Sheet1").Cells(Z, i).Value = "0" Then
Leave(L) = Ws.Cells(Z, 1).Value
ElseIf Sheets("Sheet1").Cells(Z, i).Value = "-2" Then
Join(J) = Ws.Cells(Z, 1).Value
End If
Next Z
Next i
'Print array
End With
Thanks for any pointers/help in advance!
I believe this procedure accomplishes what you are looking for. You will need to modify the range in which you are searching and the destination sheet information, but the meat of the procedure is here:
Sub abc_Dictionary()
Dim oWS As Worksheet
Dim RangeToSearch As Range
Dim myCell As Range
Dim UniqueDict As Object
Set oWS = Worksheets("Sheet1")
Set RangeToSearch = oWS.Range("B1:B26") 'You can set this dynamically however you wish
Set UniqueDict = CreateObject("Scripting.Dictionary")
'Now we search the range for the given values.
For Each myCell In RangeToSearch
If (myCell.Text = "0" Or myCell.Text = "-2") And Not UniqueDict.exists(oWS.Range("A" & myCell.Row).Text) Then
UniqueDict.Add oWS.Range("A" & myCell.Row).Text, oWS.Range("A" & myCell.Row).Text
End If
Next
'Now we have a dictionary object with the unique values of column a
'So we just iterate and dump into Sheet2
Dim d As Variant
Dim Val As Variant
Dim DestRow As Integer
DestRow = 1 'This is the first row of data we will use on Sheet 2
d = UniqueDict.Items
For Each Val In d
Worksheets("Sheet2").Range("A" & DestRow).Value = Val
DestRow = DestRow + 1
Next
Set UniqueDict = Nothing
Set RangeToSearch = Nothing
Set oWS = Nothing
End Sub
My code begins with assigning the sheet and grabbing the row count
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
lastRow22 As Long
lastRow22 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
I have the following which put the entire column into an array from column 1 to 80
Dim arrEntireWs2() as Variant
With ws2
arrEntireWs2 = .Range(.Cells(2,1),.Cells(lastRow22,80)).Value
End With
Then I loop through it
Dim lngArrEntireWs2Index as Long
For lngArrEntireWs2Index = LBound(arrEntireWs2,1) to Ubound(arrEntireWs2,1)
'Things I want to do
Next lngArrEntireWs2Index
My question is how do I grab the value at a certain column on the row that it is looping through? Like how would I grab what is on column 10 while going through the loop?
This is what youre looking for....
Dim lngArrEntireWs2Index as Long
For lngArrEntireWs2Index = LBound(arrEntireWs2,1) to Ubound(arrEntireWs2,1)
If arrEntireWs2(lngArrEntireWs2Index, 10) Then
debug.print; arrEntireWs2(lngArrEntireWs2Index, 10)
End if
Next lngArrEntireWs2Index
this looks better to me
Dim ws2 as workbook
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim arr2 as Variant
With ws2
arr2 = .UsedRange
End With
Dim i as Long
For i= LBound(arr2,1) to Ubound(arr2,1)
If arr2(i, 11) Then
debug.print; arr2(i, 11)
End if
Next i
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