I have a macro that runs through the data and outputs it in a specific format to a different sheet. Issue is, it errors out after row 65,536 has been populated, which I'm guessing is a limit imposed by MS:
Sub Macro1()
'
' Macro1 Macro
'
'
Sheets.Add.Name = "Sheet2"
Worksheets("Sheet2").Cells(1, 1).Value = "datacol1"
Worksheets("Sheet2").Cells(1, 2).Value = "datacol2"
Worksheets("Sheet2").Cells(1, 3).Value = "datacol3"
Worksheets("data").Activate
SourceColumn = 2
SourceRow = 2
Cells(SourceRow, 1).Activate
targetRow = SourceRow
targetcolumn = 1
While Cells(1, SourceColumn).Value <> ""
While ActiveCell.Value <> ""
Worksheets("Sheet2").Cells(targetRow, targetcolumn).Value = ActiveCell.Value
Worksheets("Sheet2").Cells(targetRow, targetcolumn + 1).Value = Worksheets("Data").Cells(1, SourceColumn).Value
Worksheets("Sheet2").Cells(targetRow, targetcolumn + 2).Value = Worksheets("Data").Cells(SourceRow, SourceColumn).Value
SourceRow = SourceRow + 1
targetcolumn = 1
targetRow = targetRow + 1
Cells(SourceRow, 1).Activate
Wend
SourceColumn = SourceColumn + 1
SourceRow = 2
Cells(SourceRow, 1).Activate
Wend
With Worksheets("Sheet2").Sort
.SetRange Range(Cells(2, 1), Cells(targetRow, 3))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
What can I add in this macro so when it does hit this limit of 65,536 it creates a new worksheet and keeps going?
I don't think it's an Excel limitation. I think the issue is your variable is undefined, so VBA is taking its best guess using a datatype that is insufficient to handle the row number you are giving it. By changing the datatype to a long, I think you will fix your issue.
As a demonstration, this should address both issues. For illustration purposes, I made the sheets split at 100,000 rows (rather than 65k to show it will work), but you can change this to 1,000,000 or whatever the real limit is. I made it 100,000 just to prove it does split.
Sub Macro1()
Dim wsFrom, wsTo As Worksheet
Dim SourceRow, SheetNumber, TargetRow As Long
Dim val As String
Set wsFrom = Worksheets("data")
SheetNumber = 2
SourceRow = 2
val = wsFrom.Cells(SourceRow, 1).Text
While val <> ""
Sheets.Add.Name = "Sheet" & SheetNumber
Set wsTo = Worksheets("Sheet" & SheetNumber)
wsTo.Cells(1, 1).Value = "datacol1"
wsTo.Cells(1, 2).Value = "datacol2"
wsTo.Cells(1, 3).Value = "datacol3"
TargetRow = 2
While val <> "" And TargetRow < 100000
wsTo.Cells(TargetRow, 1).Value = wsFrom.Cells(SourceRow, 1).Value
wsTo.Cells(TargetRow, 2).Value = wsFrom.Cells(SourceRow, 2).Value
wsTo.Cells(TargetRow, 3).Value = wsFrom.Cells(SourceRow, 3).Value
SourceRow = SourceRow + 1
TargetRow = TargetRow + 1
val = wsFrom.Cells(SourceRow, 1).Text
Wend
' insert your sort logic here
SheetNumber = SheetNumber + 1
Wend
End Sub
Related
So how do i put this i am a vba rookie and i have been trying to make an excel file and the purpose is that it should be an inventory of all items one sheet is for putting items in and other is for giving them away. But that is not the problem, the thing is i wanted to have a page called "databaseinventory" where all products that are taken out are writen down but my value is doing strange. (look at the image)
So this is the input screen and if i type this
this is the output on a different sheet but i don't want it to be 0
I noticed if i change the input and add 3 rows it works but that prevents me of typing more then one product
this is the output that i want to have and i really don't know what is wrong with the code
Sub Btn_Clickweggegeven()
Dim x As Long
Dim Givenaway As Worksheet
Dim Inventory As Worksheet
Dim productn As String
Dim erow As Long
Dim rng As Range
Dim rownumber As Long
Dim row As Long
Dim wsData As Worksheet
Dim wsIn As Worksheet
Dim nextRow As Long
Dim BtnText As String
Dim BtnNum As Long
Dim strName As String
x = 2
Do While Cells(x, 1) <> ""
' go through each item on list
productn = Cells(x, 1)
' if item is not new then add quanity to total Inventory
With Worksheets("Inventory").Range("A:A")
Set rng = .Find(What:=productn, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'if item is new add item to the bottom of Inventory list
If rng Is Nothing Then
erow = Worksheets("Inventory").Cells(1, 1).CurrentRegion.Rows.Count + 1
Worksheets("Inventory").Cells(erow, 1) = Worksheets("Givenaway").Cells(x, 1)
Worksheets("Inventory").Cells(erow, 2) = Worksheets("Givenaway").Cells(x, 2)
Worksheets("Inventory").Cells(erow, 3) = Worksheets("Givenaway").Cells(x, 3)
Worksheets("Inventory").Cells(erow, 4) = Worksheets("Givenaway").Cells(x, 4)
GoTo ende
Else
rownumber = rng.row
End If
End With
Worksheets("Inventory").Cells(rownumber, 2).Value = Worksheets("Inventory").Cells(rownumber, 2).Value _
- Worksheets("Givenaway").Cells(x, 2).Value
Worksheets("Inventory").Cells(rownumber, 4).Value = Worksheets("Inventory").Cells(rownumber, 4).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
ende:
x = x + 1
Loop
'after complete delete items from Givenaway list
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
Set wsIn = Worksheets("Givenaway")
Set wsData = Worksheets("Databaseinventory")
With wsData
nextRow = .Cells(.Rows.Count, "A") _
.End(xlUp).Offset(1, 0).row
End With
With wsData
With .Cells(nextRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, 2).Value = productn
.Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
End With
End Sub
This code is deleting the value
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
before this line copies it to Databaseinventory
Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
It appears to work if you have 3 rows is because on exit from the Do While Cells(x, 1) <> "" loop the value of x will be 3. After deleting the first record then Worksheets("Givenaway").Cells(x, 2).Value will be the value for the third record.
The database update routine also need to be within the loop
Option Explicit
Sub Btn_Clickweggegeven()
Dim wb As Workbook, rng As Range
Dim wsInv As Worksheet, wsGiven As Worksheet, wsData As Worksheet
Dim iRow As Long, iDataRow As Long, iInvRow As Long
Dim sProduct As String, nValue As Single
Set wb = ThisWorkbook
Set wsGiven = wb.Sheets("GivenAway")
Set wsInv = wb.Sheets("Inventory")
Set wsData = wb.Sheets("Databaseinventory")
iDataRow = wsData.Cells(Rows.Count, 1).End(xlUp).row
iRow = 2
With wsGiven
Do While .Cells(iRow, 1) <> ""
sProduct = .Cells(iRow, 1)
nValue = .Cells(iRow, 2)
' if item is not new then add quanity to total Inventory
With wsInv.Range("A:A")
Set rng = .Find(What:=sProduct, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If rng Is Nothing Then
iInvRow = wsInv.Cells(Rows.Count, 1).End(xlUp).row + 1
wsInv.Cells(iInvRow, 1).Resize(1, 4).Value = .Cells(iRow, 1).Resize(1, 4).Value
Else
iInvRow = rng.row
wsInv.Cells(iInvRow, 2).Value = wsInv.Cells(iInvRow, 2).Value - nValue
wsInv.Cells(iInvRow, 4).Value = wsInv.Cells(iInvRow, 4).Value + nValue
End If
' write to database
iDataRow = iDataRow + 1
With wsData.Cells(iDataRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
.Offset(0, 1) = sProduct ' col B
.Offset(0, 2) = wsInv.Cells(iInvRow, 3).Value + nValue ' col C ??
End With
iRow = iRow + 1
Loop
End With
'delete from GivenAway
wsGiven.Range("A2").Resize(iRow, 3).Delete
MsgBox iRow - 2 & " records processed", vbInformation
End Sub
I have a table which contains merged cells both column and rows as shown in attached picture. I want to unmerge "Only" rows while leaving columns merged. Consider the following snippet of table. In the image attached "Contract
For y = 1 To lRow
p = 1
c = y
d = 1
z = lRow + y
t = Cells(y, 1).Value
For x = 1 To t
Cells(z, p).Value = Cells(c, d).Value
Cells(c, d).Select
' Debug.Print
Selection.End(xlToRight).Select
c = ActiveCell.Row
d = ActiveCell.Column
p = p + 1
Next
Next
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
With c.MergeArea.Rows
.UnMerge
' .Formula = c.Formula
End With
'
'startcolumn = ActiveCell.Column
'endcolumn = Selection.Columns.Count + startcolumn - 1
'startrow = ActiveCell.Row
'endrow = Selection.Rows.Count + startrow - 1
End If
Next
End Sub
Based on your snapshot of requirements , I have wrote a very simple code which shall appear to be crude but I have kept it this way so that you can adjust its various elements as per your actual data. Sample data taken by me and results obtained are shown in the snapshot pasted below, which is followed by code.
Sub Merge_unmerge()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim LastRow As Long
Dim LastCol As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Set rng = ws.Range("A1:D" & LastRow)
For Each cell In rng
cell.UnMerge
Next cell
For i = 2 To LastRow
If Range("A" & i) = "" Then
Range("A" & i).Value = Range("A" & i - 1).Value
End If
Next i
For i = 2 To LastRow
If Range("D" & i) = "" Then
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
For i = 1 To LastRow Step 2
Range("B" & i & ":C" & i).Merge
Range("B" & i & ":C" & i).HorizontalAlignment = xlCenter
Next i
End Sub
Never mind. I solved for the issue at hand. Posting if it helps others.
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
startcolumn = c.Column
endcolumn = c.MergeArea.Columns.Count + startcolumn - 1
startrow = c.Row
endrow = c.MergeArea.Rows.Count + startrow - 1
With c.MergeArea.Rows
.UnMerge
.Formula = c.Formula
End With
For J = startrow To endrow
Application.DisplayAlerts = False
Range(Cells(J, startcolumn), Cells(J, endcolumn)).Merge
Application.DisplayAlerts = True
Next
End If
Next
End Sub
I tried to make macro for my daily job, but i cannot use IF as formula due to so many item in my excel file, so solution is to convert formula to VBA code.
I need help to convert if formula to VBA code in excel as below:
=IF(J2<>J1,AD2-X2,AE1-X2).
Here is an answer to your question. However, it is limited to only work with OP information. Also, if the calculations are taking too long then, you should try setting your calculation to Manual (Formulas->Calculation Options->Manual).
Option Explicit
Public Sub RunIF()
Dim vntOut As Variant
Dim rngSame As Range
With ActiveSheet
Set rngSave = .Range("X2")
If (LCase(Trim(.Range("J2").Value)) <> LCase(Trim(.Range("J1").Value))) Then
vntOut = .Range("AD2").Value - rngSave.Value
Else
vntOut = .Range("AE1").Value - rngSave.Value
End If
.Range("AE2").value = vntOut
Set rngSave = Nothing
End With
End Sub
And here is your code converted to use Column J:
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Dim i as long
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
For i = 2 to LastRow
set r = .Range("J" & I)
'For Each r In .Range("J2:J" & LastRow)
If LCase(Trim(r.Value)) <> LCase(Trim(r.Offset(-1, 0).Value)) Then
'ae2 = "AD2" - "x2"
r.Offset(0, 21).Value = r.Offset(0, 20).Value - r.Offset(0, 14).Value
Else
'ae2 = "AE1" - "x2"
r.Offset(0, 21).Value = r.Offset(-1, 21).Value - r.Offset(0, 14).Value
End If
set r = nothing
Next i
End With
End Sub
However, you should increment with I instead of for each as the cells are dependent on the previous row and excel may not loop through the range like you would prefer.
Excel Formula to VBA: Fill Column
Sub FillColumn()
Const cCol As Variant = "J" ' Last-Row-Column Letter/Number
Const cCol1 As Variant = "AD"
Const cCol2 As Variant = "X"
Const cCol3 As Variant = "AE"
Const cFirstR As Long = 1 ' First Row
Dim rng As Range ' Last Used Cell in Last-Row-Column
Dim i As Long ' Row Counter
Set rng = Columns(cCol).Find("*", , xlFormulas, , xlByColumns, xlPrevious)
If rng Is Nothing Then Exit Sub
For i = cFirstR To rng.Row - 1
If Cells(i + 1, cCol) <> Cells(i, cCol) Then
Cells(i + 1, cCol3) = Cells(i + 1, cCol1) - Cells(i + 1, cCol2)
Else
Cells(i + 1, cCol3) = Cells(i, cCol3) - Cells(i + 1, cCol2)
End If
Next
End Sub
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Sheets("Shipping Schedule").Select
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "N").End(xlUp).Row
For Each r In .Range("N2:N" & LastRow)
If r.Value <> "" Then
r.Offset(0, 19).Value = ………………………………….
End if
Next r
End With
End Sub
I'm trying to copy a range from one sheet to another, but ignoring blank rows, and making sure there aren't blank rows in the destination.
After looking on this site, I've successfully used the code below.
However, I want to expand this to a large data range and it seems to take an absolute age. Any ideas on a more efficient code? Slight newbie here!
Thanks!
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim Source As Worksheet
Dim Destination As Worksheet
Dim i As Integer
Dim j As Integer
Set Source = Sheet1
Set Destination = Sheet4
j = 2
For i = 9 To 10000
If Source.Cells(i, 2).Value <> "" Then
Destination.Cells(j, 1).Value = Source.Cells(i, 1).Value
Destination.Cells(j, 2).Value = Source.Cells(i, 2).Value
Destination.Cells(j, 3).Value = Source.Cells(i, 3).Value
Destination.Cells(j, 4).Value = Source.Cells(i, 4).Value
Destination.Cells(j, 5).Value = Source.Cells(i, 5).Value
Destination.Cells(j, 6).Value = Source.Cells(i, 6).Value
Destination.Cells(j, 7).Value = Source.Cells(i, 7).Value
Destination.Cells(j, 8).Value = Source.Cells(i, 8).Value
Destination.Cells(j, 9).Value = Source.Cells(i, 9).Value
j = j + 1
End If
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
End Sub
[Edited to add a bit of clarity]
Replace your for loop with codes below.
Method 1: union all the range you would like to copy, and paste them at once.
Dim copyRange As Range
For i = 9 To 10000
If Source.Cells(i, 2).Value <> "" Then
If copyRange Is Nothing Then
Set copyRange = Source.Range(Source.Cells(i, 1), Source.Cells(i, 9))
Else
Set copyRange = Union(copyRange, Source.Range(Source.Cells(i, 1), Source.Cells(i, 9)))
End If
End If
Next i
copyRange.Copy Destination.Cells(2, 1)
Method 2(recommended): Use an autofilter for filtering the data.
Dim sourceRng As Range
Set sourceRng = Source.Range(Source.Cells(9, 1), Source.Cells(10000, 9))
sourceRng.AutoFilter Field:=2, Criteria1:="<>"
sourceRng.Copy Destination.Cells(2, 1)
Source.AutoFilterMode = False
Looping through worksheet rows is almost the slowest way to process data blocks. The only thing slower is looping through both rows and columns.
I'm not sure how many records you have but this processed 1500 rows of dummy data in ~0.14 seconds.
Option Explicit
Sub Macro4()
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim i As Long, j As Long, k As Long, arr As Variant
On Error GoTo safe_exit
appTGGL bTGGL:=False
Set wsSource = Sheet1
Set wsDestination = Sheet4
'collect values from Sheet1 into array
With wsSource
arr = .Range(.Cells(9, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 7)).Value
End With
'find first blank in column B
For j = LBound(arr, 1) To UBound(arr, 1)
If arr(j, 2) = vbNullString Then Exit For
Next j
'collect A:I where B not blank
For i = j To UBound(arr, 1)
If arr(i, 2) <> vbNullString Then
For k = 1 To 9: arr(j, k) = arr(i, k): Next k
j = j + 1
End If
Next i
'clear remaining rows
For i = j To UBound(arr, 1)
For k = 1 To 9: arr(i, k) = vbNullString: Next k
Next i
'put values sans blanks into Sheet4
With wsDestination
.Cells(2, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
safe_exit:
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.EnableEvents = bTGGL
.ScreenUpdating = bTGGL
.DisplayAlerts = bTGGL
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End With
Debug.Print IIf(bTGGL, "end: ", "start: ") & Timer
End Sub
I have code that runs and does what I want it to do with the click of the command button, however when executing, it runs very slow. The code grabs data from one sheet and inserts/formats it into another sheet in two separate tables that have been converted into range. I did this because I need to automatically update two different graphs with certain data. I'm still new with VBA coding and any kind of direction or help to make the code run faster is appreciated, whether that be tips or ways to get rid of unnecessary code since it is probably longer than it needs to be.
Public Sub Button1_Click() ' Update Button
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim lastRowPart As Long
Dim lastRowCW As Long
Dim lastRowQty As Long
Dim lastRowQtyLeft As Long
Dim lastRowDescrip As Long
Dim i, j, k As Integer
Dim IO As Worksheet: Set IO = Sheets("Inventory Overview")
Dim TD As Worksheet: Set TD = Sheets("Trend Data")
'1. Copies and formats data
lastRowPart = IO.Cells(Rows.count, "F").End(xlUp).Row
lastRowDescrip = IO.Cells(Rows.count, "G").End(xlUp).Row
lastRowQtyLeft = IO.Cells(Rows.count, "O").End(xlUp).Row
lastRowQty = IO.Cells(Rows.count, "I").End(xlUp).Row
lastRowCW = IO.Cells(Rows.count, "L").End(xlUp).Row
TD.Cells.UnMerge ' reset***
j = 2
k = 2
For i = 2 To lastRowCW
If IO.Cells(i, "L").Value = "Unknown" Then
TD.Cells(j, "G").Value = IO.Cells(i, "L").Value
TD.Cells(j, "H").Value = IO.Cells(i, "F").Value
TD.Cells(j, "I").Value = IO.Cells(i, "I").Value
TD.Cells(j, "J").Value = IO.Cells(i, "O").Value
TD.Cells(j, "K").Value = IO.Cells(i, "G").Value
j = j + 1
Else
TD.Cells(k, "A").Value = IO.Cells(i, "L").Value
TD.Cells(k, "B").Value = IO.Cells(i, "F").Value
TD.Cells(k, "C").Value = IO.Cells(i, "I").Value
TD.Cells(k, "D").Value = IO.Cells(i, "O").Value
TD.Cells(k, "E").Value = IO.Cells(i, "G").Value
k = k + 1
End If
Next
' Autofit
TD.range("B1:B" & lastRowPart).Columns.AutoFit
TD.range("E1:E" & lastRowDescrip).Columns.AutoFit
TD.range("H1:H" & lastRowPart).Columns.AutoFit
TD.range("K1:K" & lastRowDescrip).Columns.AutoFit
'2. Sort Cells
Dim LastRow As Long
LastRow = TD.Cells(Rows.count, 5).End(xlUp).Row
With TD.Sort ' sorts data from A to Z
.SetRange TD.range("A2:E" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'3. Merge CW Cells
' rngMerge = range for parts reworked/left with known CW
' URngMerge = range for parts reported with unknown CW
Dim rngMerge As range, URngMerge As range, cell As range, lastRowMerge As Long, ULastRowMerge As Long
lastRowMerge = TD.Cells(Rows.count, 1).End(xlUp).Row
ULastRowMerge = TD.Cells(Rows.count, 7).End(xlUp).Row
Set rngMerge = TD.range("A1:A" & lastRowMerge)
Set URngMerge = TD.range("G1:G" & ULastRowMerge)
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
MergeAgain2:
For Each cell In URngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain2
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub