Remove empty row after loop when moving to next worksheet while copying - excel

I am trying to combine several worksheets into one more pivot-friendly layout.
I copy/paste from the existing worksheets into a new worksheet and rearrange the data. This works fine, but when the loop moves on to the next worksheet it adds an empty row below the data.
I know that this is a minor inconvenience but i want to wrangle the data as little as possible before turning it into a pivot table.
My code so far:
Sub NewPivot()
Dim iRow As Long, iWorksheetIndex As Long, iNumberOfWorksheets As Long, iRowCounter As Long, iCol As Long, lastCol As Long
Dim wbkSource As Workbook
Dim wksSource As Worksheet
Dim wbkTarget As Workbook
Dim wksTarget As Worksheet
Dim strActiveWorkbook As String
Workbooks.Open ("C:\\Source.xlsm")
Set wbkSource = Workbooks("Sheets.xlsm")
iWorksheetIndex = 1
Set wksSource = wbkSource.Worksheets(iWorksheetIndex)
strActiveWorkbook = ThisWorkbook.Name
Set wbkTarget = Workbooks(strActiveWorkbook)
Set wksTarget = wbkTarget.Worksheets(1)
iNumberOfWorksheets = wbkSource.Application.Sheets.Count 'Count number of worksheets
iRowCounter = 0
For iWorksheetIndex = 1 To iNumberOfWorksheets
lastCol = wbkSource.Worksheets(iWorksheetIndex).Cells(1, 1).End(xlToRight).Column
For iCol = 0 To lastCol - 2 'last Column
For iRow = 2 To 5
If wbkSource.Worksheets(iWorksheetIndex).Cells(1, 2 + iCol) <> "Sum" Then 'don't copy if the header of the data is a sum
'Copy data 01
wbkSource.Worksheets(iWorksheetIndex).Cells(iRow, 2 + iCol).Copy
wksTarget.Cells(iWorksheetIndex + iRowCounter, 1).PasteSpecial Paste:=xlPasteValues
'Copy data 02
wbkSource.Worksheets(iWorksheetIndex).Cells(1, 2 + iCol).Copy
wksTarget.Cells(iWorksheetIndex + iRowCounter, 2).PasteSpecial Paste:=xlPasteValues
'Copy data 03
wbkSource.Worksheets(iWorksheetIndex).Cells(iRow, 1).Copy
wksTarget.Cells(iWorksheetIndex + iRowCounter, 3).PasteSpecial Paste:=xlPasteValues
Else
Exit For
End If
iRowCounter = iRowCounter + 1
Next iRow
Next iCol
Next iWorksheetIndex
End Sub
EDIT: Spreadsheet layout:
Worksheet 1
Header1 | Header2
Data | Data
Data | Data
Data | Data
Worksheet 2
Header1 | Header2 | Header2
Data | Data | Data
Data | Data | Data
Data | Data | Data
Basically all worksheets contain a header and have varying numbers of columns but the same amount of rows (5)

Related

Split tables in one excel sheet to multiple other sheets based on continuity of data

I am trying to automatically split multiple tables in one excel sheet to different sheets, based on the continuity of the data. Once there is a gap, like an empty row, it then starts a new sheet for the next table, and it is to be done multiple times as I have a lot of data in one sheet.
This is an image of a snippet of the data, the continuity of the data is not fixed, i.e. sometimes it is 4 rows, sometimes 20 etc. I want it to take the whole row of input.
You can use below code to extract all data to different worksheet
Sub spreaddate()
Dim totalrows As Integer
Dim countworksheet As Integer
Dim lastcopy As Integer
Dim Sht As Worksheet
Set Sht = ActiveSheet
countworksheet = 1
lastcopy = 2
totalrows = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To totalrows + 1
If Cells(i, 1).Value = "" Then
Sheets.Add.Name = countworksheet
Sht.Range("1:1").Copy Sheets(countworksheet).Cells(1, 1)
Sht.Range(lastcopy & ":" & i - 1).Copy Sheets(countworksheet).Cells(2, 1)
lastcopy = i + 1
countworksheet = countworksheet + 1
Sht.Activate
End If
Next i
End Sub

Find a data with a specific title and copy the whole column to another sheet

I would like to create a VBA, to copy my data in "RAW", to paste into sheet "summary" by the specific column arrangement in my "summary" sheet.
for example, if sheet "summary" column A is COUNTER CODE, then copy the data from sheet "RAW" which the data is in B2-B5 and paste into my sheet "summary" A2-A5
I tried to use the below VBA, which it works. but in the event if the column data in "RAW" is different, i will not be getting the correct data.
Sub TRANSFERDATA()
Dim LASTROW As Long, EROW As Long
LASTROW = Worksheets("RAW").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LASTROW
Worksheets("RAW").Cells(i, 1).Copy
EROW = Worksheets("summary").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 2)
Worksheets("RAW").Cells(i, 2).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 1)
Worksheets("RAW").Cells(i, 3).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 4)
Worksheets("RAW").Cells(i, 4).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 3)
Next i
End Sub
Thanks!
summary
RAW
Test the next code, please. Yo do not have to copy cell by cell. In the way the code is designed, it will also work for a header which is not identic with the one in 'RAW' worksheet, but 'RAW' header string is contained:
Sub TestFindCopyInPlace()
Dim shR As Worksheet, shSum As Worksheet, colHeadR As String
Dim colHS As Range, lastCol As Long, lastRow As Long, i As Long
Set shR = Worksheets("RAW")
Set shSum = Worksheets("summary")
lastCol = shR.Cells(1, Columns.count).End(xlToLeft).Column
lastRow = shR.Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastCol
colHeadR = shR.Columns(i).Cells(1, 1).value
Set colHS = shSum.Rows(1).Find(colHeadR)' find the cell with the header of the one being copied
If Not colHS Is Nothing Then 'Find method will find a column containing colHeadR in its header string...
shR.Range(shR.Cells(2, i), shR.Cells(lastRow, i)).Copy Destination:=colHS.Offset(1, 0)
Else
MsgBox "The column header """ & colHeadR & """ could not be found." & vbCrLf & _
"Please check the spelling or whatever you think it is necessary..."
End If
Next i
End Sub
The code should work for as many columns your 'RAW` worksheet contains...
To make the process fully automatic, please use the following code:
Sub TRANSFERDATA()
Const rawSheet As String = "RAW"
Const summarySheet As String = "summary"
'===================================================================================
' Find the last column in both sheets
'===================================================================================
Dim rawLastCol As Integer
Dim summaryLastCol As Integer
rawLastCol = Worksheets(rawSheet).Cells(1, Columns.Count).End(xlToLeft).Column
summaryLastCol = Worksheets(summarySheet).Cells(1, Columns.Count).End(xlToLeft).Column
'===================================================================================
' Iterate over all columns in the RAW sheet and transfer data to the summary sheet
'===================================================================================
Dim col As Integer
For col = 1 To rawLastCol
'Read column header
Dim header As String
header = Worksheets(rawSheet).Cells(1, col).Value
'Find this header in the summary sheet
Dim col2 As Integer
For col2 = 1 To summaryLastCol
If Worksheets(summarySheet).Cells(1, col2).Value = header Then
'Transfer all values from RAW to the summary sheet
Dim lastRow As Integer
lastRow = Worksheets(rawSheet).Cells(Rows.Count, col).End(xlUp).row
If lastRow > 1 Then 'to handle the case where a column contains no data
'First clear previous data
Range(Worksheets(summarySheet).Cells(2, col2), Worksheets(summarySheet).Cells(lastRow, col2)).ClearContents
'Now, transform data
Dim row As Integer
For row = 2 To lastRow
Worksheets(summarySheet).Cells(row, col2).Value = Worksheets(rawSheet).Cells(row, col).Value
Next row
End If
'Break
Exit For
End If
Next col2
Next col
End Sub
This will work event if the number of columns or rows change in your sheets

Cut specified number of rows in selected range VBA

I have problem,
I have e.g 180 rows in sheet, I want to choose randomly e.g 18 rows in range from A2 to the end of sheet except first because there will be title of columns, and paste it to new sheet,
The following will achieve what you are wanting, it will generate 18 random numbers between 2 and your last row with data, in your case row 180 and then copy that row into the next free row in Sheet2:
Sub foo()
Dim wsOriginal As Worksheet: Set wsOriginal = ThisWorkbook.Worksheets("Sheet1")
Dim wsDestination As Worksheet: Set wsDestination = ThisWorkbook.Worksheets("Sheet2")
'declare and set the worksheets you are working with, amend as required
Dim i As Long, LastRowOrig As Long, LastRowDest As Long
LastRowOrig = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A on your Sheet with data
For i = 1 To 18 'loop 18 times
RandNumber = Int((LastRowOrig - 2 + 1) * Rnd + 2)
'generate a random number between 2 and 180 (Last Row)
LastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
'get the last row with data on Destination sheet and offset by one (i.e. next free row)
wsOriginal.Rows(RandNumber).Copy 'copy the row
wsDestination.Rows(LastRowDest).PasteSpecial xlPasteAll 'paste the row
Next i
End Sub
UPDATE:
To reflect your comment and add a new workbook with the random rows in it, use the following code:
Sub foo()
Dim wsOriginal As Worksheet: Set wsOriginal = ThisWorkbook.Worksheets("Sheet1")
Dim wsDestination As Worksheet
Dim i As Long, LastRowOrig As Long, LastRowDest As Long
Set NewWorkbook = Workbooks.Add 'create a new workbook
With NewWorkbook
.Title = "Random Rows" 'You can modify this value.
.SaveAs Filename:="C:\Users\doneby\Desktop\RandomGeneratedRows.xlsx"
'amend the line above to the path you and name of the file you want to create
End With
Set wsDestination = NewWorkbook.Worksheets("Sheet1") 'specify the Sheet of the new workbook
'declare and set the worksheets you are working with, amend as required
LastRowOrig = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A on your Sheet with data
For i = 1 To 18 'loop 18 times
RandNumber = Int((LastRowOrig - 2 + 1) * Rnd + 2)
'generate a random number between 2 and 180 (Last Row)
LastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
'get the last row with data on Destination sheet and offset by one (i.e. next free row)
wsOriginal.Rows(RandNumber).Copy 'copy the row
wsDestination.Rows(LastRowDest).PasteSpecial xlPasteAll 'paste the row
Next i
NewWorkbook.Close SaveChanges:=True
'close and save the new workbook
End Sub

Looping through worksheets and trying to count the data in columns

I have a workbook of ten sheets. In sheet 1, I want to list out sheet names (sheets 3 thru 10), column heading values in the sheet (columns 8 and beyond only) and for that column the number of cells that have data in it.
My code works for two of these three requirements. On my sheet 1 (named: SheetName Columns) I get the Sheet Names in column A and Column Heading in column B, however not having any luck getting that sheet/columns number of data rows.
On my sheet 1, column A gets duplicated per number of columns after column 7 on that sheet and that is fine.
Sub ListColumnHeadings()
Dim cNbrs As Long, i As Integer, tr As Long, tc As Long, wst As Worksheet
Dim charList(300, 300) As String
Dim ws As Worksheet, OutputRow As Long
Dim myRange As Range
Dim NumRows As Integer
Dim colNbr As Range
Set shSkip1 = ThisWorkbook.Sheets("SheetName Record Cnt")
Set shList = ThisWorkbook.Sheets("SheetName Columns")
OutputRow = 1
On Error Resume Next
For Each ws In Worksheets
If ws.Name <> shList.Name And ws.Name <> shSkip1.Name Then
cNbrs = ws.Range("A1").CurrentRegion.Columns.Count
For i = 8 To cNbrs
shList.Cells(OutputRow, "A").Value = ws.Name
shList.Cells(OutputRow, "B").Value = ws.Cells(1, i)
Set myRange = ws.Columns(i).Select
NumRows = ws.Application.WorksheetFunction.CountA(myRange)
If NumRows > 0 Then
shList.Cells(OutputRow, "C").Value = NumRows
End If
OutputRow = OutputRow + 1
Next i
End If
Next ws
End Sub
It's because of your use of Set myRange... You don't need to .Select it. Just change that line to Set myRange = ws.Columns(i)
If you want to leave .Select, then the next line should be
NumRows = ws.application.worksheetfunction.counta(selection), but it is highly recommended you avoid using .Select, this is just for your info.

Creating an Excel Macro to populate values

Creating macros in Excel is not my strong point so I'm wondering if someone is able to help.
I have a small table with product values, though not every cell has a value. What I'm trying to do is write a macro to create a list on a separate sheet. The macro I have written works for the first column but that's where it stops.
For example
List | aa | bb | cc
a |1 | 15 | -
b |2 | 23 | 12
c |- | 17 | 5
d |4 | - | -
Should appear on Sheet 2 like so
- List| aa
- a | 1
- b | 2
- d | 4
- List| bb
- a | 15
- b | 23
- c | 17
- List| cc
- b | 12
- c | 5
At the moment, only aa shows correctly on the 2nd sheet and none of the other columns.
The macro I have so far is
Sub Button2_Click()
Dim Column As Integer
Column = 1
newrow = 1
Do Until Worksheets("Sheet1").Cells(Column, 1).Value = ""
If Worksheets("Sheet1").Cells(Column, 2).Value <> "" Then
Worksheets("Sheet2").Cells(newrow, 1).Value = Worksheets("Sheet1").Cells(Column, 1).Value
Worksheets("Sheet2").Cells(newrow, 2).Value = Worksheets("Sheet1").Cells(Column, 2).Value
newrow = newrow + 1
End If
Column = Column + 1
Loop
End Sub
This is what I was suggesting. This code sample is based on the above sample data. If the structure of the sample changes then you will have to amend the code accordingly. I have commented the code so that you shouldn't have a problem understanding it. But if you do, simply post back :)
CODE
Option Explicit
Sub Sample()
'~~> Input/Output Sheets
Dim wsI As Worksheet, wsO As Worksheet
Dim Lrow As Long, ORow As Long, i As Long
Dim rngToFilter As Range
'~~> Set the input, output sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> Set the output row in the new sheet
ORow = 1
With wsI
'~~> Get last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rngToFilter = .Range("A1:D" & Lrow)
'~~> Hide Col C to E
.Range("C:E").EntireColumn.Hidden = True
'~~> Loop through Col B to Col D
For i = 2 To 4
'~~> Remove any filters
.AutoFilterMode = False
'~~> Copy Header viz List| aa, List| bb
Union(.Cells(1, 1), .Cells(1, i)).Copy wsO.Range("A" & ORow)
'~~> Get next empty row
ORow = ORow + 1
'~~> Filter, offset(to exclude headers) and copy visible rows
With rngToFilter
.AutoFilter Field:=i, Criteria1:="<>"
'~~> Copy the filtered results to the new sheet
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsO.Range("A" & ORow)
End With
ORow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
'~~> Unhide/Hide relevant columns
.Columns(i).EntireColumn.Hidden = True
.Columns(i + 1).EntireColumn.Hidden = False
'~~> Remove any filters
.AutoFilterMode = False
Next i
'~~> Unhide all columns
.Range("B:E").EntireColumn.Hidden = False
End With
End Sub
SCREENSHOT

Resources