I'm new to VBA and currently busting my head to maintain item list in excel which is connected to database.
sheet1 columns (starts from column B)
UID | itemno. | itemweight | processed
sheet2 same headers(starts from column A)
UID | itemno. | itemweight | deleted
I framed this theoretical target and coded it, tried several times.
It is not looping :( and not achieving my target.
Any suggestions will be helpful! Thanks in advance
Following are my steps framed with the code:
Private Sub CommandButton3_Click()
' Loop until no new UID found
' 1. GoTo Sheet2 to First/Next Cell with UID
' 2. Read UID value
' 3. GoTo Sheet1
' 4. Search in UID column for read UID
' 5. if UID found
' 5.1 get data from Sheet1
' 5.2 GoTo Sheet 2
' 5.3 Past data in right cells
' 5.4 GoTo Sheet 1
' 5.5 Put check flag in proccessed field
' 6. if UID NOT found
' 6.1 GoTo Sheet 2
' 6.2 Put delete flag in delete field
' Loop End
'
' GoTo Sheet1
' Search for all parts with no checked process flag
' Copy datasets
' GoTo Sheet2
' Add data to the end of table
---------------------------------------------------
Dim dict As Object
Dim proc As Range
Dim del As Range
Dim chk, myrange As Range
Set dict = CreateObject("Scripting.dictionary")
Dim sheet1 As Worksheet, Sheet2 As Worksheet
Set sheet1 = ThisWorkbook.Worksheets("MetadataSheet")
Set Sheet2 = ThisWorkbook.Worksheets("PlanningData")
' Read values from sheet2 to dictionary
Dim lastRow As Long
lastRow = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To lastRow
' Store value to dictionary
dict(Sheet2.Cells(i, 1).Value) = 1
Next
' Read from sheet1 and check if each value exists
lastRow = sheet1.Cells(sheet1.Rows.Count, 2).End(xlUp).Row
For i = 1 To lastRow
' Check if value exists in dictionary
If dict.exists(sheet1.Cells(i, 2).Value) Then
' found
sheet1.Range("B2:D2").Select
Selection.Copy
Sheet2.Select
Sheet2.Range("A2:C2").Select
ActiveSheet.Paste
sheet1.Select
sheet1.Range("E2").Select
Set proc = sheet1.Range("E2")
proc.Value = "X"
Else
' not found
Sheet2.Select
Set del = Sheet2.Range("D2")
del.Value = "X"
End If
Next
'for initial load
sheet1.Select
Set chk = sheet1.Range("E2", "E" & lastRow)
For Each chk In myrange
If chk.Value = "" Then
chk.Range("B2:D2").Select
Selection.Copy Destination:= _
Sheets(2).Range("A65536").End(xlUp)(2, 1)
End If
Next chk
End Sub
This code is almost working good. For the first run it loads the data from sheet1 to sheet2.
During second run I get an type mismatch error!
Dim x As Long
Dim y As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastRow1, lastRow2, lastrow3 As Long
Dim proc As Range
Dim del As Range
Set ws1 = Worksheets("Metadatasheet")
Set ws2 = Worksheets("PlanningData")
y = 2 'this is the first row where your data will output
x = 2 'this is the first row where you want to check for data
lastRow1 = ws1.Range("B:B").Find("*", SearchDirection:=xlPrevious).Row
lastRow2 = ws2.Range("A:A").Find("*", SearchDirection:=xlPrevious).Row
If Not IsEmpty(ws2.Range("B2").Value) Then
Do Until ws1.Range("B2") = ""
For x = 2 To lastRow2
If ws1.Range("B2", "B" & lastRow1).Value = ws2.Range("A2", "A" & lastRow2).Value Then
ws2.Range("A" & y).Value = ws1.Range("B" & x).Value
ws2.Range("B" & y).Value = ws1.Range("C" & x).Value
ws2.Range("C" & y).Value = ws1.Range("D" & x).Value
Set proc = ws1.Range("E" & y)
proc.Value = "X"
y = y + 1
Else
Set del = ws2.Range("D" & y)
del.Value = "X"
End If
Next x
Loop
Else
'lastrow3 = ws1.Range("E:E").Find("*", SearchDirection:=xlPrevious).Row
For x = 2 To lastRow1
If Not ws1.Range("E" & y).Value = "X" Then
ws2.Range("A" & y).Value = ws1.Range("B" & x).Value
ws2.Range("B" & y).Value = ws1.Range("C" & x).Value
ws2.Range("C" & y).Value = ws1.Range("D" & x).Value
y = y + 1
End If
Next x
End If
End Sub
Related
Is it possible to correct the two algorithms? when I do a filtering by criteria, I calculate two columns, "Pareto_Analysis" and "cumulates", my problem is: that the two algorithms don't calculate the data filtered, but calculate all the lines.
Here is an example of filtering on this screen printer
Code algorithm for "Pareto_Analysis":
Sub calculDefect()
Dim ws As Worksheet
Set ws = Sheet7
With ws
Const SourceColumn As String = "G"
Const DestColumn As String = "K"
Const TotalCell As String = "H4" 'total defect of all defect
Const StartRow As Integer = 11
Const EndRow As Integer = 100
For i = StartRow To EndRow
ws.Range(DestColumn & i).Formula = "=(" & SourceColumn & i & "/" & TotalCell & ")*100"
Next i
End With
End Sub
Code algorithm for "cumule":
Sub calculatCumule()
Dim ws As Worksheet
Set ws = Sheet7
With ws
LastRow = ActiveSheet.Cells(Rows.Count, 11).End(xlUp).Row
Range("L11") = Range("K11").Value
Range("L12").FormulaR1C1 = "=R[-1]C+RC[-1]"
Range("L12").AutoFill Destination:=Range("L12:L" & LastRow & "")
End With
End Sub
To clarify the question further, here are some more screen dumps:
Here I chose the criteria I wanted:
Displays the data I have chosen:
Calculate the "pareto" column based on the column "Quantity_prod" and the column"cumule" based on the column "pareto":
And if you notice in the last picture the rest of the columns has 0 and 100 that repeats, normally should just calculate the 4 lines.
Try the 2 modified 'Algorithms" code below.
First, you need to run Sub calculDefect, and after run Sub calculatCumule.
Sub calculDefect()
Dim ws As Worksheet
Const SourceColumn As String = "G"
Const DestColumn As String = "K"
Const TotalCell As String = "H4" 'total defect of all defects
Const StartRow As Long = 11
Dim EndRow As Long, i As Long
Set ws = Sheet7
With ws
EndRow = .Range("G" & StartRow).End(xlDown).Row '<-- get last row with data in Column G
For i = StartRow To EndRow
.Range(DestColumn & i).Formula = "=(" & SourceColumn & i & "/" & TotalCell & ")*100"
Next i
End With
End Sub
'====================================================================
Sub calculatCumule()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Sheet7
With ws
LastRow = .Cells(.Rows.Count, "K").End(xlUp).Row '<-- get last row with data in Column K
.Range("L11") = .Range("K11").Value
.Range("L12").FormulaR1C1 = "=R[-1]C+RC[-1]"
.Range("L12:L" & LastRow).FillDown
End With
End Sub
Screen-shot of the results I've got running this code:
Edit 1: same 2 "algorithms" that work when you filter the data:
Sub calculDefect()
Dim ws As Worksheet
Const SourceColumn As String = "G"
Const DestColumn As String = "K"
Const TotalCell As String = "H4" 'total defect of all defects
Const StartRow As Long = 11
Dim EndRow As Long, i As Long
Dim VisRng As Range, C As Range
Set ws = Sheet7
With ws
EndRow = .Range("G" & StartRow).End(xlDown).Row '<-- get last row with data in Column G
' set visible range to only filtered cells in Column G
Set VisRng = .Range(Range(SourceColumn & StartRow), Range(SourceColumn & EndRow)).SpecialCells(xlCellTypeVisible)
.Range(TotalCell).Formula = WorksheetFunction.Sum(VisRng) '<-- re-calculate Total defects according to visible range
For Each C In VisRng
.Range(DestColumn & C.Row).Formula = "=(" & SourceColumn & C.Row & "/" & TotalCell & ")*100"
Next C
End With
End Sub
'=================================================================
Sub calculatCumule()
Dim ws As Worksheet
Dim VisRng As Range, C As Range
Dim StartRow As Long
Dim LastRow As Long
Set ws = Sheet7
With ws
LastRow = .Cells(.Rows.Count, "K").End(xlUp).Row '<-- get last row with data in Column K
StartRow = 11 '<-- init value
' set visible range to only filtered cells in Column G
Set VisRng = .Range(Range("K" & StartRow), Range("K" & LastRow)).SpecialCells(xlCellTypeVisible)
StartRow = VisRng.Item(1).Row '<-- update first row in visible range
For Each C In VisRng
If C.Row = StartRow Then
.Range("L" & C.Row) = .Range("K" & C.Row).Value
Else
.Range("L" & C.Row).Formula = "=SUBTOTAL(9,K" & StartRow & ":K" & C.Row & ")"
End If
Next C
End With
End Sub
Screen-shot of the results I've got running this code when filtering "Type_defect" to CPE02:
I want to copy certain cells (for, if then condition) to an other sheet. I got great help with my code and it smoothly runs through the lines so far, but still it doesn't do exactly what I want.
I want to look for the value 848 in column A, if there is 848 in a certain row X, I want to copy the content of the following cells: XA, XN, XO, XAM, AH, XP XE and XF to the other worksheet. But: the columns do not remain the same. They change from one to the other workbook like:
Copy value in the column X in “source” --> Column Y in “target”
A --> A, N-->B, O-->C, AM -->D, AH -->G, P-->I, E-->J, F-->K
After checking and copy pasting all the needed cells of rows containing 848 in column A, we do the same for the rows containing 618 in column A.
A --> A N-->B O-->C AM -->D T -->G P-->I E-->J F-->K
As I said, the code in general works properly, it's just that I don't get the right values to the cell I want them to. Any ideas? Thanks a lot!
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("invoices_eCMS.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim SearchValues() As String: SearchValues = Split("848,618", ",")
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Data exAlps")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long, z As Long: z = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For j = 0 To UBound(SearchValues)
For i = 2 To LastRow
If .Cells(i, 1).Value = SearchValues(j) Then
.Range(.Cells(i, 1), .Cells(i, 14)).Copy
'.Cells(i, 1).Copy
wsDest.Range("A" & z).PasteSpecial xlPasteValues
z = z + 1
', .Cells(i, 14)).Copy
End If
Next i
Next j
End With
End Sub
Updated Code:
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("invoices_eCMS.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim SearchValues() As String: SearchValues = Split("848,618", ",")
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Data exAlps")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long, z As Long: z = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For j = 0 To UBound(SearchValues)
For i = 2 To LastRow
If .Cells(i, 1).Value = SearchValues(j) Then
wsDest.Range("A" & z).Value = .Range("A" & i).Value
wsDest.Range("B" & z).Value = .Range("N" & i).Value
wsDest.Range("C" & z).Value = .Range("O" & i).Value
wsDest.Range("D" & z).Value = .Range("AM" & i).Value
wsDest.Range("G" & z).Value = .Range("AH" & i).Value
wsDest.Range("I" & i).Value = .Range("P" & z).Value
wsDest.Range("J" & i).Value = .Range("E" & z).Value
wsDest.Range("K" & i).Value = .Range("F" & z).Value
z = z + 1
', .Cells(i, 14)).Copy
End If
Next i
Next j
End With
End Sub
The problem exists here:
.Range(.Cells(i, 1), .Cells(i, 14)).Copy
wsDest.Range("A" & z).PasteSpecial xlPasteValues
where are you defining a specific range to copy and specific place to paste.
Since you want to copy certain columns in one sheet to different columns in your other sheet, you'll need to specify each one separately. See my example below. I didn't do each iteration, but you can just copy the code I wrote and adjust for each:
wsDest.Range("A" & z).Value = .Range("A" & i).Value
wsDest.Range("B" & z).Value = .Range("N" & i).Value
wsDest.Range("C" & z).Value = .Range("O" & i).Value
'... and so on for each cell that needs to be copied
If it's not clear, replace the code where I stated the problem was with the code I provided as a solution.
I have two sheets. I want to check the value in one column against the value in the same column in the second sheet. If they match, then I want to migrate the string data from the Notes column to the new sheet. (essentially I'm seeing if last week's ticket numbers are still valid this week, and carrying over the notes from last week).
I am trying to do this with the following code (using columns Z for the data, BE for the notes):
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Dim partNo2 As Range
Dim partNo1 As Range
Dim partNo3 As Range
For Each partNo2 In ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo1 In ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo3 In ws1.Range("BE1:BE" & ws2.Range("BE" & Rows.Count).End(xlUp).Row)
If StrComp(Trim(partNo2), Trim(partNo1), vbTextCompare) = 0 Then
ws2.Range("BE" & partNo1.Row) = partNo3
End If
Next
Next
Next
'now if no match was found then put NO MATCH in cell
For Each partNo1 In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If IsEmpty(partNo1) Then partNo1 = ""
Next
End Sub
Untested:
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim c As Range, f As Range
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set rng1 = ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
Set rng2 = ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each c In rng1.Cells
Set f = rng2.Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
f.EntireRow.Cells(, "BE").Value = c.EntireRow.Cells(, "BE").Value
End If
Next c
'now if no match was found then put NO MATCH in cell
For Each c In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If Len(c.Value) = 0 Then c.Value = "NO MATCH"
Next
End Sub
This accomplishes the same result (maybe with the exception of the columns E & F at the bottom with NO MATCH). It's just a different way of going about it. Instead of using ranges, I'm just looking at each cell and comparing it directly.
TESTED:
Sub NoteMatch()
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("Z" & Rows.Count).End(xlUp).row
lastRow2 = Sheets("Sheet2").Range("Z" & Rows.Count).End(xlUp).row
For sRow = 2 To lastRow1
tempVal = Sheets("Sheet1").Cells(sRow, "Z").Text
For tRow = 2 To lastRow2
If Sheets("Sheet2").Cells(tRow, "Z") = tempVal Then
Sheets("Sheet2").Cells(tRow, "BE") = Sheets("Sheet1").Cells(sRow, "BE")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet2").Cells(lRow, "Z").Text
For sRow = 2 To lastRow1
If Sheets("Sheet1").Cells(sRow, "Z") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet2").Cells(lRow, "BE") = "NO MATCH"
End If
Next lRow
End Sub
Need some help with the following:
I have several worksheets with the same structure and within each worksheet I have two columns (let's call them X & Y) that I need to copy with their cellvalues (letter-number combination) and also copy the values of Column A-F to an own sheet for X and Y.
On the "new" sheet I want to put X/Y to column A sort the values after A and attach a constant hyperlink to each cellvalue in A.
So X or Y goes to A and A-F to B-G.
Then I want to make column F or the new G clickable so that it will take me to the row in the according worksheet.
X and Y don't always happen to be in column X or Y but I think this can be solved with a "name search".
When I execute my code then for example worksheet3 will overwrite the values of worksheet1 and my hyperlink structure is wrong too. The sorting is left out since that is working.
Function CopyAndSort(ByRef mySheet As Worksheet)
' If mySheet.Name <> "Sheet1" Then
' Exit Function
' End If
mySheet.Activate
Set sheetCS = Sheets("CopyAndSort Sheet")
sheetCS.Range("A:A").Value = ""
lastRowCS = Range("X:X").Cells.Find("*", , , , , xlPrevious).Row
rowNumber = 1
For rowCopy = 5 To lastRowFO
sheetCopy = Range("BE" & rowCopy)
If Trim(sheetCopy) <> "" Then
sheetCopy = Replace(sheetCopy, """", "")
If InStr(1, sheetCopy, ",", vbTextCompare) <> 0 Then
sheetCopyArray = Split(sheetCopy, ",")
Else
sheetCopyArray = Array(sheetCopy)
End If
For Each copy In sheetCopyArray
rowNumber = rowNumber + 1
copy_Value = copy
' test for url
' sheetCS.Cells(rowNumber, 1).Formula = "=HYPERLINK(""ConstURL & copyValue"")"
sheetCS.Cells(rowNumber, 1) = copy_Value
copy_Value = Cells(rowCopy, 1)
sheetCS.Cells(rowNumber, 2) = copy_Value
copy_Value = Cells(rowCopy, 2)
sheetCS.Cells(rowNumber, 3) = copy_Value
copy_Value = Cells(rowCopy, 3)
sheetCS.Cells(rowNumber, 4) = copy_Value
copy_Value = Cells(rowCopy, 4)
sheetCS.Cells(rowNumber, 5) = copy_Value
copy_Value = Cells(rowCopy, 5)
sheetCS.Cells(rowNumber, 6) = copy_Value
Next
End If
Next
So how can I manage to not overwrite the values and attach the correct hyperlink syntax, plus making colum G clickable?
And can I use one function for X and Y?
Some code examples would help me alot.
Thank you.
UPDATE:
i forgot to mention that X & Y will always be next to each other.
Example:
Sheet1:
|ColA|ColB|ColC|ColD|ColF|....|ColX|ColY|
Sheet2: here "ColX" is in ColQ and ColY in ColR
|ColA|ColB|ColC|ColD|ColF|....|ColXinColQ|ColYinColR|
CopySheet_of_X: now copy ColX plus ColA-ColF of Sheet1 and do the same for Sheet2 where X is in ColQ
Output for both sheets:
|ColX|ColA|ColB|ColC|ColD|ColF|
CopySheet_of_Y: now copy ColY plus ColA-ColF of Sheet1 and do the same for Sheet2 where Y is in ColR
Output for both sheets:
|ColY|ColA|ColB|ColC|ColD|ColF|
Hyperlink:
so now the values of ColX and ColY should be concatenated with a preceding hyperlink:
If a cell in ColX has the value of "someValue1" then it should be turned into myurl://sometext=someValue1
and I don't know the right way to jump back to the row when clicking on ColF.
Try this. Paste this in a module and run Sub Sample.
Option Explicit
Const hLink As String = "d3://d3explorer/idlist="
Sub Sample()
Dim sheetsToProcess
Set sheetsToProcess = Sheets(Array("Sheet1", "Sheet2"))
CopyData sheetsToProcess, "CopySheet_of_X", "FirstLinkValue"
'~~> Similarly for Y
'CopyData sheetsToProcess, "CopySheet_of_Y", "SecondLinkValue"
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' USAGE '
' wsI : Worksheet Collection '
' wsONm : name of the new sheet for output '
' XY : Name of the X or Y Header '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Sub CopyData(wsI, wsONm As String, XY As String)
Dim ws As Worksheet, sSheet As Worksheet
Dim aCell As Range
Dim lRow As Long, LastRow As Long, lCol As Long, i As Long, j As Long
Dim MyAr() As String
'~~> Delete the Output sheet if it is already there
On Error Resume Next
Application.DisplayAlerts = False
Sheets(wsONm).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'~~> Recreate the output sheet
Set ws = Sheets.Add: ws.Name = wsONm
'~~> Create Headers in Output Sheet
ws.Range("A1") = XY
wsI(1).Range("A3:F3").Copy ws.Range("B1")
'~~> Loop throught the sheets array
For Each sSheet In wsI
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
With Sheets(sSheet.Name)
'~~> Find the column which has X/Y header
Set aCell = .Rows(3).Find(What:=XY, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If aCell Is Nothing Then
'~~> If not found, inform and exit
MsgBox XY & " was not found in " & .Name, vbCritical, "Exiting Application"
Exit Sub
Else
'~~> if found then get the column number
lCol = aCell.Column
'~~> Identify the last row of the sheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the X Column and split values
For i = 4 To lRow
If InStr(1, .Cells(i, lCol), ",") Then '<~~ If values like A1,A2,A3
MyAr = Split(.Cells(i, lCol), ",")
For j = 0 To UBound(MyAr)
'~~> Add hyperlink in Col 1
With ws
.Cells(LastRow, 1).Value = MyAr(j)
.Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
End With
.Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)
'~~> Add hyperlink in Col 2
With ws
.Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
End With
LastRow = LastRow + 1
Next j
Else '<~~ If values like A1
'~~> Add hyperlink in Col 1
With ws
.Cells(LastRow, 1).Value = Sheets(sSheet.Name).Cells(i, lCol)
.Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
End With
.Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)
'~~> Add hyperlink in Col 2
With ws
.Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
End With
LastRow = LastRow + 1
End If
Next i
End If
End With
Next
'~~> Sort the data
ws.Columns("A:G").Sort Key1:=ws.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub
I have a tricky situation. I have a column A with only headers and column B contains text. Now I would like to get the text from column B to start in column A. If there's text in column A, B will always be empty.
A B
Title 1
Text 1
Text 2
Title 2
Text 1
Text 2
How could I get it so the text in column B is put in column A. Range is set until a complete empty row is found. (A1 to S1 no values in the cells = empty row)
I was thinking about merging cells, but that's perhaps not neat.
Like this? This uses merging and also takes into account where A and B are both filled up.
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Sheets("Sheet5")
With ws
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To LastRow
If Application.WorksheetFunction.CountA(.Range("A" & i & ":" & "B" & i)) = 1 And _
Len(Trim(.Range("A" & i).Value)) = 0 Then
With .Range("A" & i & ":" & "B" & i)
.Merge
End With
End If
Next i
End With
End Sub
FOLLOW UP
If you don't want merging and A will always remain empty when there is a value in B then we can move the value from Col B into Col A like this
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Sheets("Sheet5")
With ws
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To LastRow
If Len(Trim(.Range("A" & i).Value)) = 0 Then
.Range("A" & i).Value = .Range("B" & i).Value
.Range("B" & i).ClearContents
End If
Next i
End With
End Sub