I am trying to make a macro for creating a pivot table. I need the Macro to select all of the data on the sheet; a friend of mine has helped me create the code above, however the macro only selects the first two columns of data instead of all 48 columns. Does anyone see any mistake we may have made? Any response would be greatly appreciated! There will always be 48 columns however there number of rows will vary from week to week.
Dim lastRow As Long
Dim lastCol As Long
lastRow = 1
lastCol = 1
While Sheets("Sheet1").Cells(lastRow, lastCol).Value <> ""
lastCol = lastCol + 1
Wend
lastCol = lastCol - 1
While Sheets("Sheet1").Cells(lastRow, 1).Value <> ""
lastRow = lastRow + 1
Wend
lastRow = lastRow - 1
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Sheet1!R1C1:R" & lastRow & "C" & lastCol, Version:=xlPivotTableVersion12).CreatePivotTable _
TableDestination:="", TableName:="PivotTable1", DefaultVersion:= _
xlPivotTableVersion12
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
To get the last columns of data try replacing
While Sheets("Sheet1").Cells(lastRow, lastCol).Value <> ""
lastCol = lastCol + 1
Wend
for
lastCol = Sheets("Sheet1").Cells(1, Sheets("Sheet1").Columns.Count).End(xlToLeft).Column
This will get you the last column on the right that has data in row 1.
and
While Sheets("Sheet1").Cells(lastRow, 1).Value <> ""
lastRow = lastRow + 1
Wend
for
lastRow = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, 1).End(xlUp).row
This will get you the last row of data that has data in column 1
If you have blank cells then this could be interfering with you setting your range. Looping to get the end values also seems very inefficient.
You likely have a blank in C1, so the loop is stopping. Try this
LastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
LastCol = 48
Related
So When i run this macro, the A column will be filled with P's and the C column will be filled with 7's, just as I intended it to.
However I also needed the H and I columns to fill with 0's and 1's respectively.
However on the workbook, each worksheet will have the H and I columns unfilled. Only H2 and I2 will be filled. And in some worksheets the H2 and I2 will be the dates (1/0/1900),(1/1/1900) respectively. In other worksheets H2 and I2 will just have a 0 and 1, respectively.
Why is this happening? And why are some of the incorrect columns dates and others are numbers? How can this be fixed?
Dim i As Long
Dim LastRow As Long
For i = 1 To Worksheets.count
With Sheets(i)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A2:A" & LastRow).Value2 = "P"
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
.Range("C2:C" & LastRow).Value2 = "7"
LastRow = .Cells(Rows.Count, "H").End(xlUp).Row
.Range("H2:H" & LastRow).Value2 = "0"
LastRow = .Cells(Rows.Count, "I").End(xlUp).Row
.Range("I2:I" & LastRow).Value2 = "1"
End With
Next i
I guess that you have run the code twice and you do not see it changing any more. To see it adding more values every time you run it:
Sub Test()
Dim i As Long
Dim LastRow As Long
For i = 1 To Worksheets.Count
With Sheets(i)
.Columns("A:XFD").NumberFormat = "General"
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A2:A" & LastRow).Value2 = "P"
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row + 1
.Range("C2:C" & LastRow).Value2 = "7"
LastRow = .Cells(Rows.Count, "H").End(xlUp).Row + 1
.Range("H2:H" & LastRow).Value2 = "0"
LastRow = .Cells(Rows.Count, "I").End(xlUp).Row + 1
.Range("I2:I" & LastRow).Value2 = "1"
End With
Next i
End Sub
The problem with (1/0/1900) and (1/1/1900) is that these cells are formatted as date. And 0 is translated to 1/0/1900 and 1 is 1/1/1900. To fix this, in code above the cells are formatted as General with this line:
.Columns("A:XFD").NumberFormat = "General"
I'm currently creating an automation that will separate the fruits for each store. Basically my file looks like below:
What I need to do is to transfer all fruits of Store X and B to column F (all fruits from different stores). The number of stores could grow as well as the fruits.
I have the code below, however, it only gets the first fruit and jump in to the next store already.
Sub test()
Dim i, lastrow As Long
lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
Cells(i, 1).Select
If Cells(i, 1).Value <> "" Then
Cells(i, 6) = Cells(i, 4).Value
End If
Next i
End Sub
I'm thinking to add another lastrow count for the fruits, however, it just continues until the last row of column D.
I suggest the following:
Option Explicit
Public Sub CopyFruitsIntoStores()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet 'if this code is for a specific sheet only then better define a sheet like Thisworkbook.Worksheets("NameOfSheet")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row 'find last row in col D it is longer than A
Dim iStore As Long 'to count the stores
Dim iRow As Long
For iRow = 2 To LastRow
If ws.Cells(iRow, 1).Value <> vbNullString Then 'if a new store begins
iStore = iStore + 1
'Use following line to write the headers for the stores
ws.Cells(1, 5 + iStore).Value = ws.Cells(iRow, 1).Value & " (Fruits)"
End If
ws.Cells(iRow, 5 + iStore).Value = ws.Cells(iRow, 4).Value
Next iRow
End Sub
Count the stores in iStore and use that store count to determine the destination column.
Also note that you need to determine the LastRow in column D not A. Column D has more entries than A has. If you use A's last row it stops too early.
The following should do what you are requesting, I check column D for the last row instead of A since those are the values you are wanting to transpose:
Sub test()
Dim i As Long, lastrow As Long
lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "D").End(xlUp).Row
For i = 2 To lastrow
Cells(i, 1).Select
If i < 6 Then
Cells(i, 6) = Cells(i, 4).Value
Else
Cells(i, 7) = Cells(i, 4).Value
End If
Next i
End Sub
First Try using below function to get Last Row, this is very handy.
Function LastRow(sh As Worksheet) As Integer
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function
One more for Last column, just in case for your Future reference.
Function LastColumn(sh As Worksheet) As Integer
On Error Resume Next
LastColumn = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function
Now the Actual working procedure
Sub test()
Dim i as Long, InptClm as integer 'good to define the variable otherwise they will be considered as variant which is at higher memory rank.
Dim LastRow As Integer: LastRow = LastRow(activeworkbook.Sheets("Type sheet name here")
With activeworkbook.Sheets("Type Sheet Name here")
For i = 2 To lastrow
' you don't have to select here as selection slows the performance of codes.
If .Cells(i, 1).Value <> "" Then
' Below code will make the column selection dynamic
inptclm = .rows(1).find(What:=.cells(i,1)&" (Fruits)",After:=Cells(1,1),Lookat:=xlwhole).column()
End If
.Cells(i, inptclm) = Cells(i, 4).Value
Next I
end with
End sub
-- Code not tested, hope it will be able to assist you.
You could use SpecialCells to isolate each blank cells group in column A
Option Explicit
Public Sub test()
Dim iArea As Long
For Each area in Range("D2", Cells(Rows.Count, "D").End(xlUp)).Offset(,-3).SpecialCells(xlCellTypeBlanks).Areas
With area.Offset(-1).Resize(.Rows.Count + 1)
Range("F1").Offset(,iArea).Value = .Cells(1,1).Value
Range("F2").Offset(,iArea).Resize(.Rows.Count).Value = .Value
End With
iArea = iArea + 1
Next
End Sub
I have a sheet with two columns. Column (E) contains ID and names from the data source and column (K) contains ID,which are extracted from comment section.
Column E contains sometime ID, starting with B2C, and sometime names and Id starting with 5. column K contains always ID starting with B2C. the length of the ID B2C is usually 11 to 13 Digit Long. the length of ID starting with 5 is 8 Digit Long.
I would like to have a VBA that checks both the columns, if there is an id starting with 5 or some Name in column E, then it should look into column K, if an ID starting with B2C is present, then it should copy to Column L, else copy the same value(from column E) to column L.
I researched through find and replace. I saw examples where exact Name of find was given and replaced with given Name. I am able to form an algorithm, but struck how to start with code in my case. the code below, has an runn time error
object varaible or with block variable not set .
Sub compare()
Dim i As Long
Dim ws As Worksheet
ws = Sheets("Sheet1")
For i = 1 To Rows.Count
If ws.Cells(i, 11).Value = "" Then
ws.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
ws.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next i
End Sub
I have an Image below, which Shows the end result.
Any lead would be appreciated.
The issue causing the error message is that you are missing a Set statement for your worksheet object. You must use Set when assigning an object to a variable, that is anything with its own methods. A simple data type without methods (String, Integer, Long, Boolean, ...) doesn't need the Set statement, and can just be directly assigned like i = 0.
Your code should be updated to:
Dim i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
' RED FLAG! Rows.Count is going to cause you to loop through the entire column,
' see the below example for how to use the UsedRange property.
For i = 1 To Rows.Count
If ws.Cells(i, 11).Value = "" Then
ws.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
ws.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next I
An alternative which avoids even using a worksheet variable would be to use a With block:
Dim r As Long
With ThisWorkbook.Sheets("Sheet1")
For r = 2 To .UsedRange.Rows.Count
.Range("L" & r).Value = .Range("E" & r).Value
If .Range("K" & r).Value = "" Then .Range("L" & r).Value = .Range("K" & r).Value
Next r
End With
Edit:
There are various ways to find the last used row, each with their drawbacks. A drawback of both UsedRange and xlCellTypeLastCell is they are only reset when you save/close/re-open the workbook. A better solution can be found in this answer.
Sub compare()
Dim r As Long, lastrow As Long, ws As WorkSheet
Set ws = ThisWorkbook.Sheets("Sheet1")
lastrow = LastRowNum(ws)
With ws
For r = 2 To lastrow
.Range("L" & r).Value = .Range("E" & r).Value
If .Range("K" & r).Value = "" Then .Range("L" & r).Value = .Range("K" & r).Value
Next r
End With
End Sub
' Function from linked question
Public Function LastRowNum(Sheet As Worksheet) As Long
LastRowNum = 1
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastRowNum = Sheet.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
This is my solution:
Option Explicit
Sub Compare()
Dim i As Long
Dim lngLastRow As Long
Dim ws As Worksheet
lngLastRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
Set ws = Worksheets(1)
With ws
.Columns(12).Clear
.Cells(1, 12) = "Extract from Comment"
For i = 1 To lngLastRow
If .Cells(i, 11).Value = "" Then
.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next i
End With
End Sub
It clears column(12) and writes Extract from comment in the first cell of the row, to make sure that everything is clean.
lngLastRow is the last row of the sheet.
My data is spreaded in many columns. In that, Column A and Column B has identical name (duplicates), while Column C to Q are values related to column B. I want to align column B to Column A while preserving subsequent values as it is.
NOTE: My question is very much similar to this one "Align identical data in two columns while preserving values in the 3rd in excel"
But in my case I want to preserve more subsequent columns (from C to Q). I played with code given as a solution by #Jeeped in that post but failed.
Can I get any help in this regards,
I have tried following code:
Sub aaMacro1()
Dim i As Long, j As Long, lr As Long, vVALs As Variant
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
vVALs = Range("B1:C" & lr)
Range("B1:C" & lr).ClearContents
For i = 1 To lr
For j = 1 To UBound(vVALs, 1)
If vVALs(j, 1) = .Cells(i, 1).Value Then
.Cells(i, 2).Resize(1, 2) = Application.Index(vVALs, j)
Exit For
End If
Next j
Next i
End With
End Sub
I have made an attempt to change range("B1:C" & lr) to range ("B1:Q" & lr), but it didnt work.
After that I have changed .Resize (1,2) to .Resize (1,3), and it copied two subsequent rows but when i inset a code with .Resize (1,4), didn't work.
Hope this edited post helps to answer my question.
With best
Based on the code in the original link, should work with any number of columns ...
Option Explicit
Option Base 1
Sub aaMacro1()
Dim i As Long, j As Long, k As Long
Dim nRows As Long, nCols As Long
Dim myRng As Range
Dim vVALs() As Variant
With ActiveSheet
nRows = .Cells(Rows.Count, 1).End(xlUp).Row
nCols = .Cells(1, Columns.Count).End(xlToLeft).Column
Set myRng = .Range(.Cells(2, 2), .Cells(nRows, nCols))
End With
nRows = nRows - 1
nCols = nCols - 1
vVALs = myRng.Value
myRng.ClearContents
For i = 1 To nRows
For j = 1 To nRows
If vVALs(j, 1) = ActiveSheet.Cells(i + 1, 1).Value Then
For k = 1 To nCols
myRng.Cells(i, k).Value = vVALs(j, k)
Next k
Exit For
End If
Next j
Next i
End Sub
Test input ...
Provides this output ...
you can try this
Option Explicit
Sub AlignDupes()
Dim lRow As Long, iRow As Long
Dim mainRng As Range, sortRange As Range
With ActiveSheet
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set mainRng = .Range("A1:A" & lRow)
Set sortRange = .Range("B1:Q1").Resize(mainRng.Rows.Count)
.Sort.SortFields.Clear
End With
Application.AddCustomList ListArray:=mainRng
With sortRange
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
iRow = 1
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Do While iRow <= lRow
Do While .Cells(iRow, 1) <> .Cells(iRow, 1).Offset(, -1)
.Rows(iRow).Insert
iRow = iRow + 1
lRow = lRow + 1
Loop
iRow = iRow + 1
Loop
End With
Application.DeleteCustomList Application.CustomListCount
End Sub
I have found the code
Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Dim lColumn As Long
Dim x As Long
Dim rng As Range
For Each rng In Range("A1:A" & LastRow)
lColumn = Cells(rng.Row, Columns.Count).End(xlToLeft).Column
For x = 1 To lColumn - 2
Range(Cells(rng.Row, "A"), Cells(rng.Row, "B")).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rng.Offset(0, x + 1)
Next x
Next rng
Application.ScreenUpdating = True
End Sub
I am trying to modify it to suit my needs but it isn't quite doing what I need it to do.
Basically, my table is like this:
A B C D
FILENAME ID FIELD1 FIELD2
1 2 3 4
and I want it to look like this:
A FILENAME 1
B ID 2
C FIELD1 3
D FIELD2 4
however, sometimes there may be more columns or rows associated with a given part of the range that is related to a set of data. right now the columns that
I don't know nearly enough about excel and vba to modify this code to do that, but it would be nice if I could.
below are a couple of links that explain closely how I want the final table to look.
http://pastebin.com/1i5MqTL7
http://imgur.com/a/PKAcy
The ID's are not unique product pointers, but that's the REAL world. Different considerations and assumptions about the consistency of your input data, but try this:
Private Sub TransposeBits()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'start will be the starting row of each set
Dim start As Long
start = 2
'finish will be the last row of each set
Dim finish As Long
finish = start
Dim lastRow As Long
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'printRow will keep track of where to paste-transpose each set
Dim printRow As Long
printRow = lastRow + 2
'lastCol will measure the column count of each set
Dim lastCol As Long
'Just dealing with a single entry here - delete as necessary
If lastRow < 3 Then
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
'in the trivial case, we can exit the sub after dealing with the one-line transpose
Exit Sub
End If
'more general case
For i = 3 To lastRow
If Not Range("A" & i).Value = Range("A" & i - 1).Value Then
'the value is different than above, so set the finish to the above row
finish = i - 1
lastCol = Cells(start, 1).End(xlToRight).Column
'copy the range from start row to finish row and paste-transpose
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
'after finding the end of a set, reset the start and printRow variable
start = i
printRow = printRow + lastCol
End If
Next i
'here we deal with the last set after running through the loop
finish = lastRow
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
End Sub
You can use the Paste Special that #Jeeped uses - just write it in code:
Sub TransposeData()
Dim rLastCell As Range
With ThisWorkbook.Worksheets("Sheet1")
'NB: If the sheet is empty this will throw an error.
Set rLastCell = .Cells.Find("*", SearchDirection:=xlPrevious)
'Copy everything from A1 to the last cell.
.Range(.Cells(1, 1), rLastCell).Copy
'Paste/Transpose in column A, one row below last row containing data.
.Cells(rLastCell.Row + 1, 1).PasteSpecial Transpose:=True
End With
End Sub