I encountered a problem in excel, I'm planning to split a multi-valued cell into rows through VBA.
This is my current table
Then I'm trying to make it like this
Thank you
This will do what you want. I'm assuming your 'Emails' column is column B and you start on row 1.
Option Explicit
Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet1").Copy After:=.Worksheets("Sheet1")
Set ws = ActiveSheet
End With
With ws
LastRow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = LastRow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub
Related
I am using the following VBA code to save each individual sheet in a .xlsx workbook into a .csv file.
Whilst the code is working well I would like to adapt the VBA code so blank columns & rows are removed from the .csv files which are being created.
Existing VBA Code:
Public Sub SaveWorksheetsAsCsv()
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.Name, xlCSV
Next
End Sub
To remove blank rows & columns I was able to get the below JavaScript working in a .hta application, but would like to integrate this same functionality into the above VBA code.
//Remove all blank rows
for(var i = usedRng.Rows.Count; i > 0; i--){
if( xlApp.CountA(usedRng.Rows(i)) == 0 ) usedRng.Rows(i).Delete();
}
//Remove all blank columns
for(var i = usedRng.Columns.Count; i > 0; i--){
if( xlApp.CountA(usedRng.Columns(i)) == 0 ) usedRng.Columns(i).Delete();
}
How can I integrate this row/column removal code into VBA?
Use below sub-routine to delete empty row/column in the spreadsheet
Sub RemoveEmptyRowColumn()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
CalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
Firstrow = ActiveSheet.UsedRange.Cells(1).Row
Lastrow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
FirstColumn = ActiveSheet.UsedRange.Cells(1).Column
LastColumn = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
'------------------
' Delete Empty Rows
'------------------
For Lrow = Lastrow To Firstrow Step -1
For LColumn = LastColumn To FirstColumn Step -1
With ActiveSheet.Cells(Lrow, LColumn)
If Not IsError(.Value) Then
If .Value = "" Then
DeleteRow = "Yes"
Else
DeleteRow = "No"
Exit For
End If
End If
End With
Next LColumn
If DeleteRow = "Yes" Then
ActiveSheet.Cells(Lrow, LColumn + 1).EntireRow.Delete
End If
Next Lrow
'---------------------
' Delete Empty Columns
'---------------------
For LColumn = LastColumn To FirstColumn Step -1
For Lrow = Lastrow To Firstrow Step -1
With ActiveSheet.Cells(Lrow, LColumn)
If Not IsError(.Value) Then
If .Value = "" Then
DeleteColumn = "Yes"
Else
DeleteColumn = "No"
Exit For
End If
End If
End With
Next Lrow
If DeleteColumn = "Yes" Then
ActiveSheet.Cells(Lrow + 1, LColumn).EntireColumn.Delete
End If
Next LColumn
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
I'm using below code in vba but it taking too much time to run. Report have 8 sheets and 450+ rows should be check in each sheet.
Sub forloop()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
lr = Cells(Rows.Count, 3).End(xlUp).Row - 1
For s = 1 To Sheets.Count
For x = lr To 1 Step -1
If Cells(x, 2) <> "" Then
Cells(x, 2).EntireRow.Delete
Next x
Next s
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Could you please suggest me any alternate method to run fast.
dim wb as workbook, sht as worksheet, lr as long, r as long
set wb = workbook.open(wbPathHere)
for each sht in wb.worksheets
lr = sht.cells(sht.rows.count, 3).End(xlUp).row - 1
for r = lr to 1 step-1
if sht.cells(r, 2) <> "" Then sht.cells(r, 2).entirerow.delete
next r
next sht
i'm actually trying to, for a command button, set a print area based on colomn A (if A is empty then this row is last row. and when the print area is set, just print it out with landscape layout. My code for now is as follow. When i clic it prints but doesn't update the print area can you help me plz
Private Sub Imprimer_Click()
ActiveSheet.Unprotect Password:="mypass"
Dim usedRangeEx As Range
Set usedRangeEx = GetUsedRangeIncludingCharts(ActiveSheet)
usedRangeEx.Activate
Debug.Print usedRangeEx.Address
ActiveSheet.Protect Password:="mypass"
End Sub
Private Function GetUsedRangeIncludingCharts(target As Worksheet) As Range
ActiveSheet.Unprotect Password:="mypass"
Dim firstRow As Long
Dim firstColumn As Integer
Dim lastRow As Long
Dim lastColumn As Integer
Dim oneChart As ChartObject
For Each cell In Range("A5:A65")
If Not IsEmpty(cell) Then
lastRow = cell.Row
End If
Next
With target
firstRow = .UsedRange.cells(1).Row
firstColumn = .UsedRange.cells(1).Column
lastColumn = .UsedRange(.UsedRange.cells.Count).Column
Set GetUsedRangeIncludingCharts = .Range(.cells(firstRow, firstColumn), _
.cells(lastRow, lastColumn))
End With
ThisWorkbook.ActiveSheet.PrintOut
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
ActiveSheet.Protect Password:="mypass"
End Function
Set your print area
Sub Button1_Click()
Dim LstRw As Long, PrnG As Range
LstRw = Cells(Rows.Count, "A").End(xlUp).Row
Set PrnG = Range("A1:C" & LstRw) ' or whatever column you want
ActiveSheet.PageSetup.PrintArea = PrnG.Address
End Sub
The problem I have a pile of data in sheet 2. It's around 6k rows.
I have some 437 I want to locate. These are specified in sheet 1 (Column A).
For these I want to copy the whole row and place it in sheet 3.
The value in sheet 1 can be found multiple times in sheet 2, I need them all.
My solution I have found VBA to search through it all. But it stops at 437.
Public Sub findfak()
Dim lastRowS1 As Long
Dim lastRowS2 As Long
Dim lastRowS5 As Long
Dim i As Long
Dim j As Long
Dim tempS1 As Long
Dim temps2 As Long
Dim tempRow As Long
lastRowS1 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
lastRowS2 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To lastRowS1
tempS1 = Sheet1.Cells(i, 1).Value
If Not IsError(Application.Match(tempS1, Sheet2.Range("A:A"), 0)) Then
lastRowS5 = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet2.Rows(i).EntireRow.Copy Destination:=Sheet5.Rows(lastRowS5 + 1)
End If
Next i
Application.ScreenUpdating = True
End Sub
Try this.
Sub findfak()
Dim lastRowS1 As Long
Dim lastRowS2 As Long
Dim lastRowS5 As Long
Dim i As Long
Dim j As Long
Dim tempS1 As Variant
Dim temps2 As Long
Dim tempRow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
'change sheets as necessary
Set ws1 = WorkSheets("Sheet5")
Set ws2 = WorkSheets("Sheet6")
Set ws3 = WorkSheets("Sheet2")
lastRowS1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lastRowS2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To lastRowS1
tempS1 = ws1.Cells(i, 1).Value
For j = 2 To lastRowS2
If ws2.Cells(j, 1) = tempS1 Then
lastRowS5 = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Rows(j).EntireRow.Copy Destination:=ws3.Rows(lastRowS5 + 1)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
I have been trying to create a macro for copying the header and insert above all the subtotal groups. So all the subtotal groups will have a heading. I tried the below macro but it is not working.
Sub header()
Rows("1:1").Select
Selection.Copy
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "P"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Total" Then
.Cells(R+1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Try the following. There are several tweaks:
1) I fixed the indenting. A matter of taste perhaps, but I find code hard to read if not logically indented.
2) I replaced the first two lines by Rows(1).Copy. There is no reason to select something in order to copy it (and 1 as an index is more idiomatic than "1:1")
3) The act of inserting the row completes the copy-paste operation. I thus recopied the header row after the insert operation. This fixes your actual problem
4) The final copy in the loop leaves Excel still looking for somewhere to paste the header row. Application.CutCopyMode = False addresses that.
Sub header()
Rows(1).Copy
Dim s As Range
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "P"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Total" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
Rows(1).Copy
End If
Next R
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub