I get an error called (Run-time error '13' ; Type mismatch).
Im new to VBA so sorry if this is a stupid question.
BaseForm = my userform
Dim iRow & iCol as integer
Sub refresh_data() ' refresh the listbox data
Set ws = ThisWorkbook.Sheets("DATA")
iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
iCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
With BaseForm
.ListBox1.ColumnCount = iCol
.ListBox1.ColumnHeads = True
If iRow > 1 Then
.ListBox1.RowSource = Range(Cells(1, 1), Cells(iRow, iCol))
Else
.ListBox1.RowSource = Range(Cells(1, 1), Cells(1, iCol))
End If
End With
End Sub
When dealing with Excel rows, use Long instead of Integer
Fully qualify your range objects. You many want to read up on Why does Range work, but not Cells?
The .RowSource expects a String
Is this what you are trying? (UNTESTED)
Option Explicit
Dim iRow As Long
Dim iCol As Long
Sub refresh_data() ' refresh the listbox data
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("DATA")
iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
iCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
With BaseForm
.ListBox1.ColumnCount = iCol
.ListBox1.ColumnHeads = True
If iRow > 1 Then
.ListBox1.RowSource = "'" & ws.Name & "'!" & _
ws.Range(ws.Cells(1, 1), ws.Cells(iRow, iCol)).Address
Else
.ListBox1.RowSource = "'" & ws.Name & "'!" & _
ws.Range(ws.Cells(1, 1), ws.Cells(1, iCol)).Address
End If
End With
End Sub
Related
I have the issue with stacking in the loop
The macro should combine all columns (changeable number of rows) into one column.
Sub CombineColumns()
Dim xRng As Range
Dim i As Integer
Dim xLastRow As Integer
On Error Resume Next
Set xRng = Application.Range("A1", Range("A1").End(xlDown).End(xlToRight))
xLastRow = xRng.Columns(1).Rows.Count + 1
For i = 2 To xRng.Columns.Count
Range(xRng.Cells(1, i), xRng.Cells(xRng.Columns(i).Rows.Count, i)).Cut
ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
xLastRow = xLastRow + xRng.Columns(i).Rows.Count
Next
End Sub
Using Array is simple and fast.
Sub test()
Dim Ws As Worksheet, toWS As Worksheet
Dim vDB, vR()
Dim i As Long, j As Integer, n As Long
Set Ws = ActiveSheet
vDB = Ws.UsedRange
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 1 To r
For j = 1 To c
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, j)
Next j
Next i
Set toWS = Sheets.Add ' set toWs = Sheets(2) ~~> set your sheet
With toWS
.Cells.Clear
.Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End With
End Sub
If I got you right you want to do sth. like that
Option Explicit
Sub CombineColumns()
Dim xRng As Range
Dim i As Long
Dim xLastRow As Long
'On Error Resume Next
Set xRng = Application.Range("A1", Range("A1").End(xlToRight))
xLastRow = lastRow(1) + 1
For i = 2 To xRng.Columns.Count
Range(xRng.Cells(1, i), xRng.Cells(lastRow(i), i)).Cut
ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
xLastRow = lastRow(1) + 1
Next
End Sub
Function lastRow(col As Long, Optional wks As Worksheet) As Long
If wks Is Nothing Then
Set wks = ActiveSheet
End If
lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row
End Function
The code still needs some improvement as it might loop over all columns espeically if there is no data.
This assumes on all your columns you have data on the 2nd row, to correctly identify the last column.
Option Explicit
Public Sub CombineColumns()
Dim LastColumn As Long, LastRow As Long, LastRowA As Long, i As Long, RngAddress As String
With ActiveSheet
' This assumes you have data on row 2 on all columns
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastColumn
' Get the last row of Col A on each iteration
LastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
' Get last row of the Col we're checking
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
' Get the used range address of the current Col
RngAddress = .Range(.Cells(1, i), Cells(LastRow, i)).Address
' Check if we have blank cells among the rows of the current Col
.Range(.Cells(1, i), Cells(LastRow, i)).Value2 = Evaluate("IF(NOT(ISBLANK(" & RngAddress & "))," & RngAddress & ")")
' Compress data (if there's no empty cells in the current Col the below line will give error, that's the role of err handling)
On Error Resume Next
.Range(.Cells(1, i), Cells(LastRow, i)).SpecialCells(xlCellTypeConstants, 4).Delete xlShiftUp
On Error GoTo 0
' Update the last row in case we compressed data
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
' Paste data in Col A
.Range(.Cells(1, i), Cells(LastRow, i)).Cut Destination:=.Range("A" & LastRowA)
Next i
Application.CutCopyMode = False
End With
End Sub
Maybe this could be a convenient solution for you :
Sub CombineColumns()
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Range("A2:A" & LastRow).Formula = "=B2 & C2 & D2 & E2 & F2 & G2 & H2" 'Insert here the columns you need to be combined
End Sub
Let me know if changes are necessary.
I am trying to split data from an Excel column in to different tabs for each unique value. For example, I'd like a tab for each unique value in the Concat field that lists only the records for that specific person.
Currently using this code, which splits the tabs out correctly, but each tab has all of the worksheet's data, not just the individualized data.
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 5
Set ws = Sheets("qReconcilers")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:N1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
How would I get those tabs to only display the data pertaining to that particular person?
Something like this should be ok for a beginning:
Public Sub TestMe()
Dim defaultColumn As Long
defaultColumn = 5 'column E
Dim wks As Worksheet
Dim sourcelastRow As Long
Set wks = Worksheets(1) 'the main worksheet
sourcelastRow = lastRow(wks.Name)
Dim cnt As Long
Dim checkCell As Range
For cnt = 2 To sourcelastRow
Set checkCell = wks.Cells(cnt, defaultColumn)
If WorksheetFunction.IsErr(Evaluate("'" & Trim(checkCell) & "'!A1")) Then
Dim newSheet As Worksheet
Set newSheet = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
newSheet.Name = Trim(checkCell.Value2)
End If
Dim targetLastRow As Long
targetLastRow = lastRow(checkCell.Value2) + 1
Worksheets(checkCell.Value2).Rows(targetLastRow).Value2 = wks.Rows(cnt).Value2
Next cnt
End Sub
Public Function lastRow(Optional strSheet As String, _
Optional column_to_check As Long = 1) As Long
Dim shSheet As Worksheet
If strSheet = vbNullString Then
Set shSheet = ActiveSheet
Else
Set shSheet = Worksheets(strSheet)
End If
lastRow = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).Row
End Function
What the code does:
loops through every cell in column number 5 of the first worksheet;
checks whether there is a worksheet with the name of this column";
WorksheetFunction.IsErr(Evaluate("'" & Trim(checkCell) & "'!A1"))
if there is no such worksheet - it creates it;
then finds the worksheet with this column and at the row after the last used row of the worksheet it writes the values of the corresponding row;
Looking to fill a variable range here. I can fill my formula to the right but when I want to fil it down, the formula disappears. I have also attached a picture and Column A starts with "Fund Name". Hope somebody can help me here thank you!! The link to the table is here. 1: https://i.stack.imgur.com/y1ZVH.png
Sub Six_Continue()
Dim Lastrow As Long
Dim lrow As Range
Dim Lastcol As Long
Dim lcol As Range
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Set lrow = Range("C5:C" & Lastrow)
Lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Set lcol = Range("C3", Cells(3, Lastcol))
Range("C5").FormulaArray = "=IFERROR(INDEX(DataTable[[Period]:[Period]],SMALL(IF(DataTable[[LP ID]:[LP ID]]=C$2,IF(DataTable[[Fund ID]:[Fund ID]]=$B5,ROW(DataTable[[Fund ID]:[Fund ID]])-ROW(DataTable[[Fund ID]:[Fund ID]]))),1)),"" "")"
Range("C5", lcol.Offset(2)).FillRight
Range("C5", lcol.Offset(2)).FillDown
End Sub
The code below worked for me (with a much simplified array formula).
Sub Six_Continue()
' 25 Jan 2018
Dim Rng As Range
Dim LastRow As Long
Dim LastClm As Long
With ActiveSheet ' better specify by name
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
Cells(5, 3).FormulaArray = "=IFERROR(INDEX(DataTable[[Period]:[Period]],SMALL(IF(DataTable[[LP ID]:[LP ID]]=C$2,IF(DataTable[[Fund ID]:[Fund ID]]=$B5,ROW(DataTable[[Fund ID]:[Fund ID]])-ROW(DataTable[[Fund ID]:[Fund ID]]))),1)),"" "")"
' .Cells(5, 3).FormulaArray = "= $a1 * $k1:$k5 * C$1"
Set Rng = Range(.Cells(5, 3), .Cells(5, LastClm))
Rng.FillRight
Set Rng = Range(.Cells(5, 3), .Cells(LastRow, LastClm))
Rng.FillDown
End With
End Sub
I am using Excel 2007. I try to copy Unit-price from the Excel file-2 data to the Excel file-1 when certain columns data matching from file-1 with file-2.
Thanks for the helps & guidance.
My VBA Code:
Sub mySales()
Dim LastRow As Integer, i As Integer, erow As Integer, Pipe_Class As String, Pipe_Description As String, End_Type As String, Pipe_Size As String
Dim wbk As Workbook
strPriceFile = "C:\Temp\File-2.xlsx"
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Pipe_Class = ""
Pipe_Description = ""
End_Type = ""
Pipe_Size = ""
Pipe_Class = ActiveSheet.Cells(i, 1).Value
Pipe_Description = ActiveSheet.Cells(i, 2).Value
End_Type = ActiveSheet.Cells(i, 3).Value
Pipe_Size = ActiveSheet.Cells(i, 4).Value
Set wbk = Workbooks.Open(strPriceFile)
Worksheets("SOR2").Select
If Cells(i, 1) = Pipe_Class And Cells(i, 2) = Pipe_Description And Cells(i, 3) = End_Type And Cells(i, 4) = Pipe_Size Then
Range(Cells(i, 12), Cells(i, 12)).Select
Selection.Copy
??? After Here how select my current file & paste ????????
Worksheets("SOR1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 12).Select
ActiveSheet.Paste
ActiveWorkbook.Save
End If
Next i
ActiveWorkbook.Close
Application.CutCopyMode = False
End Sub
I haven't checked all your code, but I have refactored what you have in your question in an attempt to open the Workbook once and to assign proper objects so that you can keep track of what action is being applied to which worksheet.
Sub mySales()
Dim LastRow As Integer, i As Integer, erow As Integer
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim strPriceFile As String
Set wbDst = ActiveWorkbook
Set wsDst = ActiveSheet
strPriceFile = "C:\Temp\File-2.xlsx"
Set wbSrc = Workbooks.Open(strPriceFile)
Set wsSrc = wbSrc.Worksheets("SOR2")
LastRow = wsDst.Range("A" & wsDst.Rows.Count).End(xlUp).Row
erow = LastRow + 1
For i = 2 To LastRow
If wsSrc.Cells(i, 1).Value = wsDst.Cells(i, 1).Value And _
wsSrc.Cells(i, 2).Value = wsDst.Cells(i, 2).Value And _
wsSrc.Cells(i, 3).Value = wsDst.Cells(i, 3).Value And _
wsSrc.Cells(i, 4).Value = wsDst.Cells(i, 4).Value Then
wsSrc.Cells(i, 12).Copy wsDst.Cells(erow, 12)
erow = erow + 1 ' your current code would always copies to the same row,
' but I **think** you probably want to copy to the
' next row each time
End If
Next i
wbSrc.Close
If erow > LastRow + 1 Then
wbDst.Save
End If
wbDst.Close
End Sub
The code is completely untested but, even if it doesn't work, at least it should give you an idea of how you should be processing multiple workbooks and multiple worksheets.
I have a spreadsheet with 800k rows and 150 columns. I'm attempting to create new worksheets based on the contents of a column. So, for example if column Y has many elements ("alpha", "beta", "gamma", etc.) then I'd like to create new worksheets named "alpha", "beta", "gamma" which contain only the rows from the original that have those respective letters. I've found two scripts that work for smaller spreadsheets, but due to the size of this particular spreadsheet, they don't work.
Here are the two scripts that I have tried:
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
this returns "overflow"
the other code that I have tried:
Sub columntosheets()
Const sname As String = "VOTERFILE_WITHABSENTEEINFORMATI" 'change to whatever starting sheet
Const s As String = "O" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub
Returns error with "excel does not have enough resources".
Is it possible to do what I want on my hardware?
You can refer to the modified subroutine in another article 'Macro for copying and pasting data to another worksheet'.
Sub CopySheet()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on
LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
' column G has the criteria eg project ref
wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit
wsAll.Copy Before:=Sheets("All")
ActiveSheet.Name = wsCrit.Range("A2")
Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=wsCrit.Range("A1:A2"), _
Unique:=False
wsCrit.Rows(2).Delete
Next I
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
End Sub