I have a ressource worksheet I need to have represented in a different format enabling it as data source for Power BI. This is representing the data 'as is' and the format I need it 'to be'.
I have created a VBA script to perform this - it does not work that well... Any suggestions/ideas on how to solve this puzzle? (the real data sheet is 250+ rows and 6-800 columns)
Sub PopulateCells()
Dim rng As Range
Dim rng2 As Range
Dim LastCell As String
Dim Dest As String
Application.ScreenUpdating = False
'Cleans BI worksheet
Ark4.Cells.Delete
'Initialize Row- and Column numbers
Startrow = 4
StartColumn = 7
EndColumn = 18
Ark3.Activate
'Finds adresses and ranges to be used in macro
Set rng = Sheets(Sheets.Count).Cells
lastrow = Last(1, rng)
dColumns = Last(2, rng)
aKol = dColumns
LastCell = Last(3, rng)
Set rng = Parent.Range("G4", LastCell)
Set rng2 = Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn))
cColumn = Round(dColumns / 12, 0) 'Total number of columns divided by 12, which equals 1 year
'Finds address on last column with data
sKol = Ark3.Cells(3, Columns.Count).End(xlToLeft).Address
'Initialize a row indicatorvariable + fills out dummy data in the BI worksheet to match the code
Ark4R = 3
Ark4.Range("A1:" & sKol).Value = "x"
' Loop all rows in the datasheet
For I = 4 To lastrow
'Loop all columns in datasheet (in group of 12)
For ii = 1 To cColumn
'Initialize a range (rng2) to see if there is data in the range
Set rng2 = Ark3.Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn))
'fills relevant data in the data source sheet
If WorksheetFunction.countA(rng2) <> 0 Then
Ark3.Range("E" & I).Value = rng2.EntireColumn.Cells(1).Value
Ark3.Range("F" & I).Value = rng2.EntireColumn.Cells(1).Offset(1).Value
aRowSource = Ark3.Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn)).Row
'Copy to data destination sheet
rng2.EntireRow.Copy 'Copy the entire row
Ark4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll 'Paste entire row to the next empty row in destination sheet
Application.CutCopyMode = False
Ark4.Range(Ark4.Cells(ActiveCell.Row, 7), Ark4.Cells(ActiveCell.Row, aKol)).ClearContents 'Clear hour-registration data in destination sheet
aRowDest = Range(Ark4.Cells(ActiveCell.Row, 7), Ark4.Cells(ActiveCell.Row, aKol)).Row 'Get row number in destionation sheet
Dest = rng2.Address(RowAbsolute:=False, ColumnAbsolute:=False) 'Get the address range of the hour-registration in the source sheet
Dest = Replace(Dest, aRowSource, aRowDest) 'Manipulate the address to match the location in the destination sheet
rng2.Copy Ark4.Range(Dest) 'Copy the range to the destination sheet
Application.CutCopyMode = False
End If
'Counter - takes the next 12 cells = 1 year
StartColumn = StartColumn + 12
EndColumn = EndColumn + 12
Next ii 'Next cColumn
'Make a new row to cater for operation hours (inserted by another procedure)
Ark3.Range(Cells(Startrow, 1), Cells(Startrow, 4)).Copy
Ark4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
'Counters
Startrow = Startrow + 1
StartColumn = 7
EndColumn = 18
Next I
End Sub
I found out that I was not referencing the ranges in the two sheet properly. After adding proper referenving the code worked.
Related
I have a macro that copies and pastes rows from input sheet to output sheet. I find PRODUCT NAME and END DATE, then copy the whole row and transpose when pasting it. I am using transpose because I want to have vertical table.
I have a problem with images because I don't know how to copy them to proper cell so they match with Name and Date. I've managed to write a script that is copying and pasting images but it puts all of them in cell A1. When I want to add range to target_sheet.Paste I am getting vba method intersect of object _application failed error.
Below you can see how input and output sheets look.
Input sheet:
Expected output sheet (with only 3 columns) :
It is very important to know that 'input' sheet contains many products with names, prices and images and there is always a blank row between them. The number of images in each row can be different (from 1 to 25).
Sub copy_paste()
Dim Cell As Range
Dim src_rng As String
Dim LR As Long
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim pic As Shape
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
target_sheet.Cells.Delete
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A10000").End(xlUp).Row + 1
If Cell.Value = "Name" Then
Cell.EntireRow.Copy
target_sheet.Range("A" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste, transpose end line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("B10000").End(xlUp).Row + 1
If Cell.Value = "Date" Then
Cell.EntireRow.Copy
target_sheet.Range("B" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste image
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("C10000").End(xlUp).Row + 1
If Cell.Value = "Image" Then
For Each pic In source_sheet.Shapes
If Not Application.Intersect(pic.TopLeftCell, Range(src_rng)) Is Nothing Then
pic.CopyPicture
target_sheet.Paste
End If
Next pic
End If
Next
Application.ScreenUpdating = True
End Sub
Please, try the next code. It follows the logic deduced from your last question edit, respectively: the former "Name" becomes "Product Name", "Date" becomes "End Date" and the row keeping the pictures is the one below "Product Name" row. It is able to process two or three product names/pictures per group:
Sub copy_paste()
Dim Cell As Range, src_rng As String, LR As Long
Dim source_sheet As Worksheet, target_sheet As Worksheet
Dim pic As Shape, arrPAddr, rngTr As Range, k As Long
Dim cellRHeight As Range, nrShapesPerRange As Long 'to be 2 or 3
nrShapesPerRange = 2 'Choose here initial number of shapes per row (2 or 3)
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
ReDim arrPAddr(1 To 2, 1 To source_sheet.Shapes.count): k = 1
target_sheet.cells.Delete: For Each pic In target_sheet.Shapes: pic.Delete: Next
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A" & rows.count).End(xlUp).row + 1
If Cell.value = "Product Name" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("A" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
arrPAddr(1, k) = Cell.Offset(1, 1).Address
arrPAddr(2, k) = rngTr.Offset(, 2).Address: k = k + 1
arrPAddr(1, k) = Cell.Offset(1, 2).Address
arrPAddr(2, k) = rngTr.Offset(1, 2).Address: k = k + 1
If nrShapesPerRange = 3 Then
arrPAddr(1, k) = Cell.Offset(1, 3).Address
arrPAddr(2, k) = rngTr.Offset(2, 2).Address: k = k + 1
End If
If cellRHeight Is Nothing Then Set cellRHeight = Cell.Offset(1)
End If
LR = target_sheet.Range("B" & rows.count).End(xlUp).row + 1
If Cell.value = "End Date" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("B" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
End If
Next
ReDim Preserve arrPAddr(1 To 2, 1 To k - 1)
'Making the row height in target_sheet equal to source_sheet column with:
target_sheet.Range("2:" & LR + 3).EntireRow.RowHeight = source_sheet.Range("A16").EntireRow.RowHeight
target_sheet.Range("A:C").EntireColumn.AutoFit
target_sheet.Range("C1").EntireColumn.ColumnWidth = cellRHeight.EntireColumn.ColumnWidth
'copy paste image:
Dim i As Long
For Each pic In source_sheet.Shapes
For i = 1 To UBound(arrPAddr, 2)
If pic.TopLeftCell.Address = arrPAddr(1, i) Then
pic.Copy: target_sheet.Paste
With target_sheet.Shapes(target_sheet.Shapes.count)
.top = target_sheet.Range(arrPAddr(2, i)).top + (target_sheet.Range(arrPAddr(2, i)).RowHeight - pic.height) / 2
.left = target_sheet.Range(arrPAddr(2, i)).left
End With
Exit For
End If
Next i
Next
Application.ScreenUpdating = True
target_sheet.Activate
MsgBox "Ready..."
End Sub
Plese, test the code and send some feedback
I am trying to copy certain column from one worksheet to another but when I apply my code, I get no errors but also no results. I get blank paper. I applied this methodolgy on copying a certain row and it was copied to another worksheet perfectly.
This is regarding the successful attempt to copy row.
The code works just fine:
Sub skdks()
Dim OSheet As Variant
Dim NSheet As Variant
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Tabelle3" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).row
End If
'If cell has "certain # then..."
If Cells(i, 1).Value = Cells(13, 2).Value Then
Cells(i, 1).EntireRow.Copy
Sheets(NSheet).Cells(NSLRow + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next i
End Sub
This little piece of code is the failed attempt to copy column to another worksheet.
Sub trial()
Dim OSheet As Variant
Dim NSheet As Variant
Dim j As Integer
Dim LColumn As Integer
Dim NSLColumn As Integer
OSheet = "Tabelle2" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LColumn = Sheets(OSheet).Cells(1, Columns.Count).End(xlToLeft).Column 'Last Column in Old Sheet
Sheets(OSheet).Activate
For j = 2 To LColumn
'Finds last column in the New Sheet
If Sheets(NSheet).Cells(1, 2) = "" Then
NSLColumn = 1
Else
NSLColumn = Sheets(NSheet).Cells(1, Columns.Count).End(xlToLeft).Column
End If
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next j
End Sub
....
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
debug.Print Cells(2, j).Address; " = "; Cells(13, 2).Address; " ---- COPY"
debug.print Cells(2, j).EntireColumn.address; Cells(2, j).EntireColumn.cells.count
debug.Print Sheets(NSheet).Cells(2, 2).Address
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
....
With the line If Cells(2, j) = Cells(13, 2) Then you compare the different cells from row 2 (B2, C2, D2, ...) with the value of cell "B13". If the value is the same you copy this column to the new worksheet.
Is there any equal value in your data? If yes you should get an error message with your code.
You try to copy the values of an entire column to the range starting with "B2". Of cause there is not enough space for this.
=> Either you reduce the source range or you start the destination range on row 1!
To add to the paste destination size, if you really want to paste the entire column, you either need to start at the beginning of the column or choose the entire column. Also, I think you want to make the paste column increase with your NSLColumn
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Columns(NSLColumn + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
I have two worksheets in one Excel workbook, and I only want to take the lines that have data in the cell (from worksheet1 into worksheet2) if Column A has data in it. My formula in worksheet 2 is =IF('Raw Data'!A2<>"", 'Raw Data'!A2,), but I actually don't want it to bring in the row at all if there is no data as shown in Rows 3 and 5. Right now it is bringing the whole row in:
In
you see that it is still bringing the row into worksheet 2 if there is no data. Any ideas how to only bring in the rows with the data?
Sub DataInCell()
Dim rw As Long
rw = 2
' Select initial sheet to copy from
Sheets("Raw Data").Select
' Find the last row of data - xlUp will check from the bottom of the spreadsheet up.
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' For loop through each row
For x = 2 To FinalRow
If Cells(x, 1).Value <> 0 Then
Range("A" & x & ":C" & x).Copy
Sheets("Sheet1").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Continue incrementing through the rows.
Cells(NextRow, 1).Select ' Find the next row.
ActiveSheet.Cells(NextRow, "A").PasteSpecial xlPasteAll ' Paste information.
Sheets("Raw Data").Select 'Reselect sheet to copy from. Probably uneccessary.
End If
Next x
End Sub
After you update the sheet names on the 3rd and 4th line, you will see that the code carries over the entire row. You can modify using Range(Cells, Cells) if you want partial ranges.
Option Explicit
Sub Non_Blanks()
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1") '<-- Master Sheet
Dim ns As Worksheet: Set ns = ThisWorkbook.Sheets("Sheet2") '<-- New Sheet
Dim i As Long, MoveMe As Range, LR As Long
For i = 2 To ms.Range("B" & ms.Rows.Count).End(xlUp).Row
If ms.Range("A" & i) = "*" Then
If Not MoveMe Is Nothing Then
Set MoveMe = Union(MoveMe, ms.Range("A" & i))
Else
Set MoveMe = ms.Range("A" & i)
End If
End If
Next i
If Not MoveMe Is Nothing Then
LR = ns.Range("A" & ns.Rows.Count).End(xlUp).Offset(1).Row
MoveMe.EntireRow.Copy
ns.Range("A" & LR).PasteSpecial xlPasteValuesAndNumberFormats
End If
End Sub
could you help me out with this problem in my vba code ? (I was trying to go through many topics about 1004 error on forums, yet I am a vba novice and was not able to deal with it..).
there is Table in RaWData sheet with headers - I need to clean the data part, then in next section I am going to copy there some of the data from other sheet where is Pivot table
Error on the line (section 'Sheet RawData cleaning):
RawData.Range(Cells(2, 1), Cells(LastRow, LastCol)).Delete
Not whole code but here is a bit:
'Exporting
Dim FZ As Workbook
Dim Cesta As Variant
Dim i As Long
Dim SubRegion As String
Dim rTable As Range
Dim CurrDate As String
Dim RawData As Worksheet
Dim SFDCReport As Worksheet
Dim MS As Worksheet
Dim DS As Worksheet
Dim DealOffice As Worksheet
Set DS = ThisWorkbook.Sheets("Data")
Set MS = ThisWorkbook.Sheets("Macro")
Cesta = Application.GetOpenFilename
Set FZ = Workbooks.Open(Filename:=Cesta, Local:=True)
Set RawData = FZ.Sheets("RawData")
Set SFDCReport = FZ.Sheets("SFDC Report")
Set DealOffice = FZ.Sheets("Coverage DealOffice")
CurrDate = MS.Range("E1").Value
For i = 1 To PRFilter
'Check if Export column is not empty for each SubRegion, if yes, skip to next Subregion(Iteration)
If IsEmpty(MS.Cells(i + 1, 2).Value) Then
GoTo NextIteration
Else 'Things to do if "Not Empty"
'SubRegion value paste into C10 so Highlights section is updated
SubRegion = MS.Cells(i + 1, 1).Value
SFDCReport.Cells(10, 3).Value = SubRegion
'Sheet SFDC Report Cleaning
With SFDCReport
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(12, .Columns.Count).End(xlToLeft).Column
.Range(Cells(14, 1), Cells(LastRow, LastCol)).Delete
End With
'Filter, Select & Copy filtered data to SFDCReport table
DS.Range("A1").CurrentRegion.AutoFilter Field:=84, Criteria1:=SubRegion
Set rTable = DS.AutoFilter.Range
Set rTable = rTable.Resize(rTable.Rows.Count - 1)
Set rTable = rTable.Offset(1) 'Move new range down to start at the first data row
rTable.Copy
SFDCReport.Cells(13, 1).PasteSpecial xlPasteValues
DealOffice.PivotTables("PivotTable1").RefreshTable 'Refresh PivotTable on DealOffice Sheet
'Sheet RawData Cleaning
LastCol = RawData.UsedRange.Columns.Count
LastRow = RawData.UsedRange.Rows.Count
RawData.Range(Cells(2, 1), Cells(LastRow, LastCol)).Delete
'Sheet CoverageDealOffice Pivot data copying to RawData
With DealOffice
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(17, .Columns.Count).End(xlToLeft).Column
.Range(Cells(17, 1), Cells(LastRow - 1, LastCol)).Copy
End With
RawData.Cells(2, 1).PasteSpecial xlPasteValues
'Formatting/other changes & Saving
SFDCReport.Activate
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
ActiveWindow.ScrollColumn = 68
DealOffice.Select
FZ.SaveAs Filename:=DirExport & "\" & CurrDate & "_NCE Deal Office Report_" & SubRegion & ".xlsb", FileFormat:=50
NextIteration:
End If
Next
Thanks guys, Gamca
not sure why this keeps copying whole data set from original to the destination.. I need only filtered data to be copied into Destination, that begins with A13 in the destination sheet SFDCReport
'Filter, Select & Copy filtered data to SFDCReport table
DS.Range("A1").CurrentRegion.AutoFilter Field:=84, Criteria1:=SubRegion
LastRow = DS.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
LastCol = DS.AutoFilter.Range.Columns.Count
Set rTable = DS.AutoFilter.Range
Set rTable = rTable.Resize(rTable.Rows.Count - 1)
Set rTable = rTable.Offset(1) 'Move new range down to start at the first data row
Set rTable2 = SFDCReport.Range(SFDCReport.Cells(13, 1), SFDCReport.Cells(LastRow, LastCol))
rTable2.Value = rTable.Value
Corrected/Solved - Thanks to some advices, I have changed the "syntax" coding to use With/End With + paid attention to include "address" into all Range objects.
part of changed code:
'Filter, Select & Copy filtered data to SFDCReport table
With DS.Range("A1").CurrentRegion
.AutoFilter Field:=84, Criteria1:=SubRegion
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy SFDCReport.Cells(13, 1)
End With
I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub
Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next
Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value
Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.
The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.