I am trying to convert a set of data to a different format for export.
I want copy only rows with values.
Starting with Column D (see attached), I want to filter for non-blank values and copy across columns B, C, D, CellD2, CellD3 in five columns of a new sheet. Then repeat the same for all columns that have a value after column D.
The data set could have multiple columns (no fixed limit) and multiple rows (no fixed limit).
This is the data I am working on (Sheet name is "LJM Fert")
This is the final result I am trying to achieve (Sheet name is "Export")
The code I have written
Sub CopyPaste()
Dim Totalrows As Long
Dim Totalcolumns As Long
Dim rowloop As Long
Dim columnloop As Long
Dim rowcount As Long
Dim columncount As Long
Dim pastestart As Long
Sheets("LJM Fert").Activate
Totalrows = ActiveSheet.UsedRange.Rows.Count
Totalcolumns = ActiveSheet.UsedRange.Columns.Count
rowcount = 4
columncount = 4
pastestart = 2
For rowloop = rowcount To Totalrows
For columnloop = columncount To Totalcolumns
If ActiveSheet.Cells(rowcount, columncount).Value <> "" Then
ActiveSheet.Cells(rowcount, 2).Copy
Sheets("Export").Activate
ActiveSheet.Cells(pastestart, 1).Paste
Sheets("LJM Fert").Activate
ActiveSheet.Cells(rowcount, 3).Copy
Sheets("Export").Activate
ActiveSheet.Cells(pastestart, 2).Paste
Sheets("LJM Fert").Activate
ActiveSheet.Cells(rowcount, columncount).Copy
Sheets("Export").Activate
ActiveSheet.Cells(pastestart, 3).Paste
Sheets("LJM Fert").Activate
ActiveSheet.Cells(2, columncount).Copy
Sheets("Export").Activate
ActiveSheet.Cells(pastestart, 4).Paste
Sheets("LJM Fert").Activate
ActiveSheet.Cells(3, columncount).Copy
Sheets("Export").Activate
ActiveSheet.Cells(pastestart, 5).Paste
Sheets("LJM Fert").Activate
End If
columncount = columncount + 1
pastestart = pastestart + 1
Next
Next
Application.CutCopyMode = False
'ThisWorkbook.Worksheets("Export").Cells(1, 1).Select
End Sub
You could do something like this:
'Define Variables
Dim shtExport As Worksheet, shtFert As Worksheet
Dim i As Integer
Dim cell as Range
'Assign Variables
Set shtExport = Sheets("Export")
Set shtFert = Sheets("LJM Fert")
i = 1 'first line where to copy data in Sheet "Export"
For Each cell In shtFert.Range("D4:G20") 'Go through each cell in table
If cell.Value <> 0 Then
shtExport.Cells(i, 1) = shtFert.Cells(cell.Row, 2) 'Column A
shtExport.Cells(i, 2) = shtFert.Cells(cell.Row, 3) 'Column B
shtExport.Cells(i, 3) = shtFert.Cells(cell.Row, cell.Column) 'Column C
shtExport.Cells(i, 4) = shtFert.Cells(2, cell.Column) 'Column D
shtExport.Cells(i, 5) = shtFert.Cells(3, cell.Column) 'Column E
i = i + 1 'use next row in sheet Export
End If
Next
What this basically do is go through each cell in the range D4:G20 of your sheet "LJM Fert", checks if this cell is different than 0, if it is: it will "copy" this cell in the Export sheet. And so on for each cell different than 0.
In any case, please make sure you don't use copy/paste, it's really slow compared to what I wrote above. Best is to set ranges, or cells, equal to each other.
Related
I have been struggling with this code. I want to loop through Column E beginning with E5, on the Sheet titled "pivot of proposal" (which is a pivot table); and every time it finds a cell with the value of "check" I want it to copy/paste value of cells A & B of the corresponding row to the sheet titled Check Payments in E & F, moving down a row each time but beginning on row 4. I tried to piece together other bits of code but it is not doing what I need it to.
Sub Loop_Check_Payments()
Dim c As Range
Dim IRow As Long, lastrow As Long, krow as long
Dim copyrow As Integer
Dim rSource As Range
Dim DataOrigin As Worksheet, DataDest As Worksheet, DataDestACH As Worksheet
On Error GoTo Whoa
'~~> Sheet Where "L" needs to be checked
Set DataOrigin = ThisWorkbook.Sheets("Pivot of proposal")
'~~> Output sheet
Set DataDest = ThisWorkbook.Sheets("CHECK PAYMENTS")
Set DataDestACH = ThisWorkbook.Sheets("ACH_WIRE PAYMENTS CASH POOLER")
Application.ScreenUpdating = False
'~~> Set you input range
Set rSource = Range("Payment_Method")
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
If c.Value = "Check" Then
DataDest.Cells(4 + IRow, 5) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(4 + IRow, 6) = DataOrigin.Cells(c.Row, 2)
IRow = IRow + 1
Else
DataDestACH.Cells(4 + kRow, 7) = DataOrigin.Cells(c.Row, 1)
DataDestACH.Cells(4 + kRow, 8) = DataOrigin.Cells(c.Row, 2)
kRow = kRow + 1
End If
Next c
Whoa:
MsgBox Err.Description
End Sub
Instead of trying to Copy/paste - you can do something like this (as PeterT alluded to in comments)
this will put values from columns A&B (ordinal 1 & 2) of the SOURCE to the same row/column in the destination:
If c.Value = "Check" Then
DataDest.Cells(c.Row, 1) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(c.Row, 2) = DataOrigin.Cells(c.Row, 2)
End If
I have a data export that pulls customer info with one row for each parent, and 8 port columns (port1, port2, etc... to port8). I need to transpose the port columns into a unique record for each port that retains the customer info in the parent. The source sheet can have 100+ records, the destination sheet will have a maximum of x8 as many records as source sheet because no row has more than 8 ports. I am struggling with how to proceed from here. My idea was to loop through each SourceData row, build an array for each row that contains all ports field values, transpose this into a new sheet and paste, and continue this until last row. The struggle is the paste destination must paste in gaps of 8, then the sheet must be filtered so blanks are not present, and then vlookup against the remaining data.
Source Format
Desired Format
Sub test3()
Dim wb As Workbook
Dim sourceData As Worksheet
Dim outputData As Worksheet
Set wb = Workbooks("Book1")
Set sourceData = Worksheets("Sheet1")
Set outputData = Worksheets("Sheet2")
Dim Rng As Range
Dim ctr As Long
ctr = 2
Dim iCol As Long, lCol As Long, lRow As Long 'iteration column, last column
Const fCol = 15 'first column
With sourceData
lCol = 22 'last used column
lRow = .Range("A" & .Rows.Count).End(xlUp).Row 'find last used row
For i = 2 To lRow
For iCol = fCol To lCol
Set Rng = Cells(i, iCol)
outputData.Cells(ctr, fCol).Value = Rng
ctr = ctr + 1
Next iCol
Next i
End With
End Sub
Edit 2: updated to include extra rows as output.
Lightly tested...
Sub test3()
Dim wsSrc As Worksheet, srcData, outData, r As Long
Dim c As Long, rOut As Long, p As Long, prt
'get input data as array
Set wsSrc = Worksheets("Sheet1")
srcData = wsSrc.Range("A2:W" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row).Value
'size output array to max potential size (+ added some space for pepwave/remote cases)
ReDim outData(1 To 10 * UBound(srcData, 1), 1 To 16)
For r = 1 To UBound(srcData, 1) 'loop input data rows
For p = 1 To 8 'loop ports
prt = srcData(r, 14 + p)
If Len(prt) > 0 Then 'if any port value...
rOut = rOut + 1 'add output row
For c = 1 To 14 'populate common columns
outData(rOut, c) = srcData(r, c)
Next c
outData(rOut, 15) = prt 'add port value
outData(rOut, 16) = srcData(r, 23) 'col W value
End If
Next p
'test to see if we're adding additional rows...
If InStr(1, srcData(r, 6), "pepwave", vbTextCompare) > 0 Then
rOut = rOut + 1
'populate pepwave row from srcdata (r,x)
End If
If InStr(1, srcData(r, 6), "data remote", vbTextCompare) > 0 Then
rOut = rOut + 1
'populate data remote row from srcdata (r,x)
End If
'done testing for additional rows
Next r
If rOut > 0 Then
Worksheets("Sheet2").Range("A2").Resize(rOut, UBound(outData, 2)).Value = outData
End If
End Sub
I am working on a dynamic worksheet which the total rows and columns of content will be changing.
What I try to do is, making an active cell going through the worksheet. It starts from the very last column that has content (I used UsedRange here), and from the 7st row down to the last row not blank.
When 1) The active cell has a color filling of index 16 or 36; 2) The active cell has no value, the cell will fetch the value storing in the matching row E.
The loop will end when hitting column E (I haven't been able to go that far yet).
I will attach my code below for all possible help, since it complies but does not return any result...Thank you again!
Sub catchCurrentAutomated()
Dim column As Integer
Dim row As Integer
Dim Cell As Range
row = 7
column = ActiveSheet.UsedRange.Columns.Count
Set Cell = ActiveCell
While range("A" & row) <> ""
If Cell.Interior.ColorIndex = 16 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
ElseIf Cell.Interior.ColorIndex = 36 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
End If
row = row + 1
column = column - 1
Wend
End Sub
Something like this should work (untested)
Sub catchCurrentAutomated()
Dim col As Long '<< use Long not Integer
Dim row As Long
Dim c As Range, ws As Worksheet, lr As Long, indx
Set ws = ActiveSheet
col = ws.UsedRange.Columns.Count
lr = ws.Cells(Rows.Count, 1).End(xlUp).row 'last occupied cell in ColA
Do While col > 5
For row = 7 To lr
With ws.Cells(row, col)
indx = .Interior.Color.Index
If (indx = 16 Or indx = 36) And Len(.Value) = 0 Then
.Value = ws.Cells(row, "E").Value
End If
End With
Next row
col = col - 1 'next column to left
Loop
End Sub
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
I have a worksheet that I need to split out into new ones by column C values. There are 8 values, so I'll need 8 worksheets. Each value has about 2-5000 corresponding rows, so this script isn't ideal because it prints row-by-row.
Sub SplitData()
Const iCol = 3 ' names in second column (B)
Const sRow = 2 ' data start in row 2
Dim wshSource As Worksheet
Dim wshTarget As Worksheet
Dim i As Long
Dim lRow As Long
Dim lngTargetRow As Long
Application.ScreenUpdating = False
Set wshSource = Sheets(1)
lRow = wshSource.Cells(wshSource.Rows.Count, iCol).End(xlUp).Row
For i = sRow To lRow
If wshSource.Cells(i, iCol).Value <> wshSource.Cells(i - 1, iCol).Value Then
Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wshTarget.Name = wshSource.Cells(i, iCol).Value
wshSource.Rows(sRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
lngTargetRow = 2
End If
wshSource.Rows(i).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
lngTargetRow = lngTargetRow + 1
Next i
Application.ScreenUpdating = True
End Sub
How would I change this up to print each value block (column C) to each worksheet instead of every row (i) individually? Would I need to implement auto-filtering by column C values and do a loop that way?
Try this out, as you well pointed, filtering would be the fastest way here:
Option Explicit
Sub Test()
Dim uniqueValues As Object
Set uniqueValues = CreateObject("Scripting.Dictionary")
Dim i As Long
With ThisWorkbook.Sheets("MainSheet") 'change MainSheet to the name of the sheet containing the data
'First let's store the unique values inside a dictionary
For i = 2 To .UsedRange.Rows.Count 'this will loop till the last used row
If Not uniqueValues.Exists(.Cells(i, 3).Value) Then uniqueValues.Add .Cells(i, 3).Value, 1
Next i
'Now let's loop through the unique values
Dim Key As Variant
For Each Key In uniqueValues.Keys
.UsedRange.AutoFilter Field:=3, Criteria1:=Key 'Filter column C by the value in the key
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'add a new sheet
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Key 'change the name of the new sheet to the key's
.UsedRange.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(Key).Range("A1") 'copy the visible range after the filter to the new sheet
Next Key
End With
End Sub